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

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

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

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

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

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

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

import Distribution.Compat.Prelude
import Prelude ()

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

import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity

import qualified Distribution.Compat.CharParsing as P

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

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

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

-- * User build targets

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

-- | Various ways that a user may specify a build target.
data UserBuildTarget
  = -- | A target specified by a single name. This could be a component
    -- module or file.
    --
    -- > cabal build foo
    -- > cabal build Data.Foo
    -- > cabal build Data/Foo.hs  Data/Foo.hsc
    UserBuildTargetSingle String
  | -- | A target specified by a qualifier and name. This could be a component
    -- name qualified by the component namespace kind, or a module or file
    -- qualified by the component name.
    --
    -- > cabal build lib:foo exe:foo
    -- > cabal build foo:Data.Foo
    -- > cabal build foo:Data/Foo.hs
    UserBuildTargetDouble String String
  | -- | A fully qualified target, either a module or file qualified by a
    -- component name with the component namespace kind.
    --
    -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
    -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
    UserBuildTargetTriple String String String
  deriving (Int -> UserBuildTarget -> ShowS
[UserBuildTarget] -> ShowS
UserBuildTarget -> FilePath
(Int -> UserBuildTarget -> ShowS)
-> (UserBuildTarget -> FilePath)
-> ([UserBuildTarget] -> ShowS)
-> Show UserBuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserBuildTarget -> ShowS
showsPrec :: Int -> UserBuildTarget -> ShowS
$cshow :: UserBuildTarget -> FilePath
show :: UserBuildTarget -> FilePath
$cshowList :: [UserBuildTarget] -> ShowS
showList :: [UserBuildTarget] -> ShowS
Show, UserBuildTarget -> UserBuildTarget -> Bool
(UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> Eq UserBuildTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserBuildTarget -> UserBuildTarget -> Bool
== :: UserBuildTarget -> UserBuildTarget -> Bool
$c/= :: UserBuildTarget -> UserBuildTarget -> Bool
/= :: UserBuildTarget -> UserBuildTarget -> Bool
Eq, Eq UserBuildTarget
Eq UserBuildTarget =>
(UserBuildTarget -> UserBuildTarget -> Ordering)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> UserBuildTarget)
-> (UserBuildTarget -> UserBuildTarget -> UserBuildTarget)
-> Ord UserBuildTarget
UserBuildTarget -> UserBuildTarget -> Bool
UserBuildTarget -> UserBuildTarget -> Ordering
UserBuildTarget -> UserBuildTarget -> UserBuildTarget
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 :: UserBuildTarget -> UserBuildTarget -> Ordering
compare :: UserBuildTarget -> UserBuildTarget -> Ordering
$c< :: UserBuildTarget -> UserBuildTarget -> Bool
< :: UserBuildTarget -> UserBuildTarget -> Bool
$c<= :: UserBuildTarget -> UserBuildTarget -> Bool
<= :: UserBuildTarget -> UserBuildTarget -> Bool
$c> :: UserBuildTarget -> UserBuildTarget -> Bool
> :: UserBuildTarget -> UserBuildTarget -> Bool
$c>= :: UserBuildTarget -> UserBuildTarget -> Bool
>= :: UserBuildTarget -> UserBuildTarget -> Bool
$cmax :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
max :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmin :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
min :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
Ord)

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

-- * Resolved build targets

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

-- | A fully resolved build target.
data BuildTarget
  = -- | A specific component
    BuildTargetComponent ComponentName
  | -- | A specific module within a specific component.
    BuildTargetModule ComponentName ModuleName
  | -- | A specific file within a specific component.
    BuildTargetFile ComponentName FilePath
  deriving (BuildTarget -> BuildTarget -> Bool
(BuildTarget -> BuildTarget -> Bool)
-> (BuildTarget -> BuildTarget -> Bool) -> Eq BuildTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BuildTarget -> BuildTarget -> Bool
== :: BuildTarget -> BuildTarget -> Bool
$c/= :: BuildTarget -> BuildTarget -> Bool
/= :: BuildTarget -> BuildTarget -> Bool
Eq, Int -> BuildTarget -> ShowS
[BuildTarget] -> ShowS
BuildTarget -> FilePath
(Int -> BuildTarget -> ShowS)
-> (BuildTarget -> FilePath)
-> ([BuildTarget] -> ShowS)
-> Show BuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildTarget -> ShowS
showsPrec :: Int -> BuildTarget -> ShowS
$cshow :: BuildTarget -> FilePath
show :: BuildTarget -> FilePath
$cshowList :: [BuildTarget] -> ShowS
showList :: [BuildTarget] -> ShowS
Show, (forall x. BuildTarget -> Rep BuildTarget x)
-> (forall x. Rep BuildTarget x -> BuildTarget)
-> Generic BuildTarget
forall x. Rep BuildTarget x -> BuildTarget
forall x. BuildTarget -> Rep BuildTarget x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BuildTarget -> Rep BuildTarget x
from :: forall x. BuildTarget -> Rep BuildTarget x
$cto :: forall x. Rep BuildTarget x -> BuildTarget
to :: forall x. Rep BuildTarget x -> BuildTarget
Generic)

instance Binary BuildTarget

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

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

  [(UserBuildTarget, Bool)]
utargets' <- (UserBuildTarget -> IO (UserBuildTarget, Bool))
-> [UserBuildTarget] -> IO [(UserBuildTarget, Bool)]
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 UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile [UserBuildTarget]
utargets

  let ([BuildTargetProblem]
bproblems, [BuildTarget]
btargets) = PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets PackageDescription
pkg [(UserBuildTarget, Bool)]
utargets'
  Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems Verbosity
verbosity [BuildTargetProblem]
bproblems

  [BuildTarget] -> IO [BuildTarget]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [BuildTarget]
btargets

checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile UserBuildTarget
t = do
  Bool
fexists <- FilePath -> IO Bool
existsAsFile (UserBuildTarget -> FilePath
fileComponentOfTarget UserBuildTarget
t)
  (UserBuildTarget, Bool) -> IO (UserBuildTarget, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UserBuildTarget
t, Bool
fexists)
  where
    existsAsFile :: FilePath -> IO Bool
existsAsFile FilePath
f = do
      Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
f
      case FilePath -> [FilePath]
splitPath FilePath
f of
        (FilePath
d : [FilePath]
_) | FilePath -> Bool
hasTrailingPathSeparator FilePath
d -> FilePath -> IO Bool
doesDirectoryExist FilePath
d
        (FilePath
d : FilePath
_ : [FilePath]
_) | Bool -> Bool
not Bool
exists -> FilePath -> IO Bool
doesDirectoryExist FilePath
d
        [FilePath]
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
exists

    fileComponentOfTarget :: UserBuildTarget -> FilePath
fileComponentOfTarget (UserBuildTargetSingle FilePath
s1) = FilePath
s1
    fileComponentOfTarget (UserBuildTargetDouble FilePath
_ FilePath
s2) = FilePath
s2
    fileComponentOfTarget (UserBuildTargetTriple FilePath
_ FilePath
_ FilePath
s3) = FilePath
s3

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

-- * Parsing user targets

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

readUserBuildTargets
  :: [String]
  -> ( [UserBuildTargetProblem]
     , [UserBuildTarget]
     )
readUserBuildTargets :: [FilePath] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets = [Either UserBuildTargetProblem UserBuildTarget]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either UserBuildTargetProblem UserBuildTarget]
 -> ([UserBuildTargetProblem], [UserBuildTarget]))
-> ([FilePath] -> [Either UserBuildTargetProblem UserBuildTarget])
-> [FilePath]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Either UserBuildTargetProblem UserBuildTarget)
-> [FilePath] -> [Either UserBuildTargetProblem UserBuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either UserBuildTargetProblem UserBuildTarget
readUserBuildTarget

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

    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
    tokens :: forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe (FilePath, Maybe FilePath))
tokens =
      (\FilePath
s -> (FilePath
s, Maybe (FilePath, Maybe FilePath)
forall a. Maybe a
Nothing)) (FilePath -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m FilePath -> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        m (FilePath, Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (FilePath
 -> Maybe (FilePath, Maybe FilePath)
 -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m FilePath
-> m (Maybe (FilePath, Maybe FilePath)
      -> (FilePath, Maybe (FilePath, Maybe FilePath)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token m (Maybe (FilePath, Maybe FilePath)
   -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m (Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (FilePath, Maybe FilePath)
-> m (Maybe (FilePath, Maybe FilePath))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' m Char
-> m (FilePath, Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (FilePath, Maybe FilePath)
forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe FilePath)
tokens2)

    tokens2 :: CabalParsing m => m (String, Maybe String)
    tokens2 :: forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe FilePath)
tokens2 =
      (\FilePath
s -> (FilePath
s, Maybe FilePath
forall a. Maybe a
Nothing)) (FilePath -> (FilePath, Maybe FilePath))
-> m FilePath -> m (FilePath, Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        m (FilePath, Maybe FilePath)
-> m (FilePath, Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (FilePath -> Maybe FilePath -> (FilePath, Maybe FilePath))
-> m FilePath -> m (Maybe FilePath -> (FilePath, Maybe FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token m (Maybe FilePath -> (FilePath, Maybe FilePath))
-> m (Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' m Char -> m FilePath -> m FilePath
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString m FilePath -> m FilePath -> m FilePath
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token))

    token :: CabalParsing m => m String
    token :: forall (m :: * -> *). CabalParsing m => m FilePath
token = (Char -> Bool) -> m FilePath
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m FilePath
P.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
':')

data UserBuildTargetProblem
  = UserBuildTargetUnrecognised String
  deriving (Int -> UserBuildTargetProblem -> ShowS
[UserBuildTargetProblem] -> ShowS
UserBuildTargetProblem -> FilePath
(Int -> UserBuildTargetProblem -> ShowS)
-> (UserBuildTargetProblem -> FilePath)
-> ([UserBuildTargetProblem] -> ShowS)
-> Show UserBuildTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserBuildTargetProblem -> ShowS
showsPrec :: Int -> UserBuildTargetProblem -> ShowS
$cshow :: UserBuildTargetProblem -> FilePath
show :: UserBuildTargetProblem -> FilePath
$cshowList :: [UserBuildTargetProblem] -> ShowS
showList :: [UserBuildTargetProblem] -> ShowS
Show)

reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems Verbosity
verbosity [UserBuildTargetProblem]
problems = do
  case [FilePath
target | UserBuildTargetUnrecognised FilePath
target <- [UserBuildTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [FilePath]
target ->
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines
          [ FilePath
"Unrecognised build target '" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
          | FilePath
name <- [FilePath]
target
          ]
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Examples:\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo          -- component name "
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"(library, executable, test-suite or benchmark)\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build Data.Foo     -- module name\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build Data/Foo.hsc -- file name\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build lib:foo exe:foo   -- component qualified by kind\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo:Data.Foo      -- module qualified by component\n"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo:Data/Foo.hsc  -- file qualified by component"

showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget :: UserBuildTarget -> FilePath
showUserBuildTarget = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
":" ([FilePath] -> FilePath)
-> (UserBuildTarget -> [FilePath]) -> UserBuildTarget -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserBuildTarget -> [FilePath]
getComponents
  where
    getComponents :: UserBuildTarget -> [FilePath]
getComponents (UserBuildTargetSingle FilePath
s1) = [FilePath
s1]
    getComponents (UserBuildTargetDouble FilePath
s1 FilePath
s2) = [FilePath
s1, FilePath
s2]
    getComponents (UserBuildTargetTriple FilePath
s1 FilePath
s2 FilePath
s3) = [FilePath
s1, FilePath
s2, FilePath
s3]

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

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

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

-- * Resolving user targets to build targets

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

{-
stargets =
  [ BuildTargetComponent (CExeName "foo")
  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")
  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")
  ]
    where
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse

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

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
resolveBuildTargets
  :: PackageDescription
  -> [(UserBuildTarget, Bool)]
  -> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets :: PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets PackageDescription
pkg =
  [Either BuildTargetProblem BuildTarget]
-> ([BuildTargetProblem], [BuildTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
    ([Either BuildTargetProblem BuildTarget]
 -> ([BuildTargetProblem], [BuildTarget]))
-> ([(UserBuildTarget, Bool)]
    -> [Either BuildTargetProblem BuildTarget])
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, Bool) -> Either BuildTargetProblem BuildTarget)
-> [(UserBuildTarget, Bool)]
-> [Either BuildTargetProblem BuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map ((UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget)
-> (UserBuildTarget, Bool) -> Either BuildTargetProblem BuildTarget
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (PackageDescription
-> UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget
resolveBuildTarget PackageDescription
pkg))

resolveBuildTarget
  :: PackageDescription
  -> UserBuildTarget
  -> Bool
  -> Either BuildTargetProblem BuildTarget
resolveBuildTarget :: PackageDescription
-> UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget
resolveBuildTarget PackageDescription
pkg UserBuildTarget
userTarget Bool
fexists =
  case Match BuildTarget -> MaybeAmbiguous BuildTarget
forall b. Eq b => Match b -> MaybeAmbiguous b
findMatch (PackageDescription -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget PackageDescription
pkg UserBuildTarget
userTarget Bool
fexists) of
    Unambiguous BuildTarget
target -> BuildTarget -> Either BuildTargetProblem BuildTarget
forall a b. b -> Either a b
Right BuildTarget
target
    Ambiguous [BuildTarget]
targets -> BuildTargetProblem -> Either BuildTargetProblem BuildTarget
forall a b. a -> Either a b
Left (UserBuildTarget
-> [(UserBuildTarget, BuildTarget)] -> BuildTargetProblem
BuildTargetAmbiguous UserBuildTarget
userTarget [(UserBuildTarget, BuildTarget)]
targets')
      where
        targets' :: [(UserBuildTarget, BuildTarget)]
targets' =
          PackageId
-> UserBuildTarget
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets
            (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg)
            UserBuildTarget
userTarget
            [BuildTarget]
targets
    None [MatchError]
errs -> BuildTargetProblem -> Either BuildTargetProblem BuildTarget
forall a b. a -> Either a b
Left ([MatchError] -> BuildTargetProblem
classifyMatchErrors [MatchError]
errs)
  where
    classifyMatchErrors :: [MatchError] -> BuildTargetProblem
classifyMatchErrors [MatchError]
errs
      | Just NonEmpty (FilePath, FilePath)
expected' <- [(FilePath, FilePath)] -> Maybe (NonEmpty (FilePath, FilePath))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(FilePath, FilePath)]
expected =
          let unzip' :: NonEmpty (b, b) -> (NonEmpty b, NonEmpty b)
unzip' = ((b, b) -> b) -> NonEmpty (b, b) -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, b) -> b
forall a b. (a, b) -> a
fst (NonEmpty (b, b) -> NonEmpty b)
-> (NonEmpty (b, b) -> NonEmpty b)
-> NonEmpty (b, b)
-> (NonEmpty b, NonEmpty b)
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')
&&& ((b, b) -> b) -> NonEmpty (b, b) -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, b) -> b
forall a b. (a, b) -> b
snd
              (NonEmpty FilePath
things, FilePath
got :| [FilePath]
_) = NonEmpty (FilePath, FilePath)
-> (NonEmpty FilePath, NonEmpty FilePath)
forall {b} {b}. NonEmpty (b, b) -> (NonEmpty b, NonEmpty b)
unzip' NonEmpty (FilePath, FilePath)
expected'
           in UserBuildTarget -> [FilePath] -> FilePath -> BuildTargetProblem
BuildTargetExpected UserBuildTarget
userTarget (NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
things) FilePath
got
      | Bool -> Bool
not ([(FilePath, FilePath)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, FilePath)]
nosuch) = UserBuildTarget -> [(FilePath, FilePath)] -> BuildTargetProblem
BuildTargetNoSuch UserBuildTarget
userTarget [(FilePath, FilePath)]
nosuch
      | Bool
otherwise = FilePath -> BuildTargetProblem
forall a. HasCallStack => FilePath -> a
error (FilePath -> BuildTargetProblem) -> FilePath -> BuildTargetProblem
forall a b. (a -> b) -> a -> b
$ FilePath
"resolveBuildTarget: internal error in matching"
      where
        expected :: [(FilePath, FilePath)]
expected = [(FilePath
thing, FilePath
got) | MatchErrorExpected FilePath
thing FilePath
got <- [MatchError]
errs]
        nosuch :: [(FilePath, FilePath)]
nosuch = [(FilePath
thing, FilePath
got) | MatchErrorNoSuch FilePath
thing FilePath
got <- [MatchError]
errs]

data BuildTargetProblem
  = -- |  [expected thing] (actually got)
    BuildTargetExpected UserBuildTarget [String] String
  | -- | [(no such thing,  actually got)]
    BuildTargetNoSuch UserBuildTarget [(String, String)]
  | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
  deriving (Int -> BuildTargetProblem -> ShowS
[BuildTargetProblem] -> ShowS
BuildTargetProblem -> FilePath
(Int -> BuildTargetProblem -> ShowS)
-> (BuildTargetProblem -> FilePath)
-> ([BuildTargetProblem] -> ShowS)
-> Show BuildTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildTargetProblem -> ShowS
showsPrec :: Int -> BuildTargetProblem -> ShowS
$cshow :: BuildTargetProblem -> FilePath
show :: BuildTargetProblem -> FilePath
$cshowList :: [BuildTargetProblem] -> ShowS
showList :: [BuildTargetProblem] -> ShowS
Show)

disambiguateBuildTargets
  :: PackageId
  -> UserBuildTarget
  -> [BuildTarget]
  -> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets :: PackageId
-> UserBuildTarget
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets PackageId
pkgid UserBuildTarget
original =
  QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (UserBuildTarget -> QualLevel
userTargetQualLevel UserBuildTarget
original)
  where
    disambiguate :: QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate QualLevel
ql [BuildTarget]
ts
      | [BuildTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BuildTarget]
amb = [(UserBuildTarget, BuildTarget)]
unamb
      | Bool
otherwise = [(UserBuildTarget, BuildTarget)]
unamb [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
forall a. [a] -> [a] -> [a]
++ QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (QualLevel -> QualLevel
forall a. Enum a => a -> a
succ QualLevel
ql) [BuildTarget]
amb
      where
        ([BuildTarget]
amb, [(UserBuildTarget, BuildTarget)]
unamb) = QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step QualLevel
ql [BuildTarget]
ts

    userTargetQualLevel :: UserBuildTarget -> QualLevel
userTargetQualLevel (UserBuildTargetSingle FilePath
_) = QualLevel
QL1
    userTargetQualLevel (UserBuildTargetDouble FilePath
_ FilePath
_) = QualLevel
QL2
    userTargetQualLevel (UserBuildTargetTriple FilePath
_ FilePath
_ FilePath
_) = QualLevel
QL3

    step
      :: QualLevel
      -> [BuildTarget]
      -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
    step :: QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step QualLevel
ql =
      (\([[(UserBuildTarget, BuildTarget)]]
amb, [[(UserBuildTarget, BuildTarget)]]
unamb) -> (((UserBuildTarget, BuildTarget) -> BuildTarget)
-> [(UserBuildTarget, BuildTarget)] -> [BuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map (UserBuildTarget, BuildTarget) -> BuildTarget
forall a b. (a, b) -> b
snd ([(UserBuildTarget, BuildTarget)] -> [BuildTarget])
-> [(UserBuildTarget, BuildTarget)] -> [BuildTarget]
forall a b. (a -> b) -> a -> b
$ [[(UserBuildTarget, BuildTarget)]]
-> [(UserBuildTarget, BuildTarget)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
amb, [[(UserBuildTarget, BuildTarget)]]
-> [(UserBuildTarget, BuildTarget)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
unamb))
        (([[(UserBuildTarget, BuildTarget)]],
  [[(UserBuildTarget, BuildTarget)]])
 -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]))
-> ([BuildTarget]
    -> ([[(UserBuildTarget, BuildTarget)]],
        [[(UserBuildTarget, BuildTarget)]]))
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(UserBuildTarget, BuildTarget)] -> Bool)
-> [[(UserBuildTarget, BuildTarget)]]
-> ([[(UserBuildTarget, BuildTarget)]],
    [[(UserBuildTarget, BuildTarget)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(UserBuildTarget, BuildTarget)]
g -> [(UserBuildTarget, BuildTarget)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UserBuildTarget, BuildTarget)]
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
        ([[(UserBuildTarget, BuildTarget)]]
 -> ([[(UserBuildTarget, BuildTarget)]],
     [[(UserBuildTarget, BuildTarget)]]))
-> ([BuildTarget] -> [[(UserBuildTarget, BuildTarget)]])
-> [BuildTarget]
-> ([[(UserBuildTarget, BuildTarget)]],
    [[(UserBuildTarget, BuildTarget)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, BuildTarget)
 -> (UserBuildTarget, BuildTarget) -> Bool)
-> [(UserBuildTarget, BuildTarget)]
-> [[(UserBuildTarget, BuildTarget)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (((UserBuildTarget, BuildTarget) -> UserBuildTarget)
-> (UserBuildTarget, BuildTarget)
-> (UserBuildTarget, BuildTarget)
-> Bool
forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating (UserBuildTarget, BuildTarget) -> UserBuildTarget
forall a b. (a, b) -> a
fst)
        ([(UserBuildTarget, BuildTarget)]
 -> [[(UserBuildTarget, BuildTarget)]])
-> ([BuildTarget] -> [(UserBuildTarget, BuildTarget)])
-> [BuildTarget]
-> [[(UserBuildTarget, BuildTarget)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, BuildTarget)
 -> (UserBuildTarget, BuildTarget) -> Ordering)
-> [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UserBuildTarget, BuildTarget) -> UserBuildTarget)
-> (UserBuildTarget, BuildTarget)
-> (UserBuildTarget, BuildTarget)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UserBuildTarget, BuildTarget) -> UserBuildTarget
forall a b. (a, b) -> a
fst)
        ([(UserBuildTarget, BuildTarget)]
 -> [(UserBuildTarget, BuildTarget)])
-> ([BuildTarget] -> [(UserBuildTarget, BuildTarget)])
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildTarget -> (UserBuildTarget, BuildTarget))
-> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
forall a b. (a -> b) -> [a] -> [b]
map (\BuildTarget
t -> (QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
t PackageId
pkgid, BuildTarget
t))

data QualLevel = QL1 | QL2 | QL3
  deriving (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 -> FilePath
(Int -> QualLevel -> ShowS)
-> (QualLevel -> FilePath)
-> ([QualLevel] -> ShowS)
-> Show QualLevel
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QualLevel -> ShowS
showsPrec :: Int -> QualLevel -> ShowS
$cshow :: QualLevel -> FilePath
show :: QualLevel -> FilePath
$cshowList :: [QualLevel] -> ShowS
showList :: [QualLevel] -> ShowS
Show)

renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
target PackageId
pkgid =
  case QualLevel
ql of
    QualLevel
QL1 -> FilePath -> UserBuildTarget
UserBuildTargetSingle FilePath
s1 where s1 :: FilePath
s1 = BuildTarget -> FilePath
single BuildTarget
target
    QualLevel
QL2 -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetDouble FilePath
s1 FilePath
s2 where (FilePath
s1, FilePath
s2) = BuildTarget -> (FilePath, FilePath)
double BuildTarget
target
    QualLevel
QL3 -> FilePath -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetTriple FilePath
s1 FilePath
s2 FilePath
s3 where (FilePath
s1, FilePath
s2, FilePath
s3) = BuildTarget -> (FilePath, FilePath, FilePath)
triple BuildTarget
target
  where
    single :: BuildTarget -> FilePath
single (BuildTargetComponent ComponentName
cn) = ComponentName -> FilePath
dispCName ComponentName
cn
    single (BuildTargetModule ComponentName
_ ModuleName
m) = ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m
    single (BuildTargetFile ComponentName
_ FilePath
f) = FilePath
f

    double :: BuildTarget -> (FilePath, FilePath)
double (BuildTargetComponent ComponentName
cn) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn)
    double (BuildTargetModule ComponentName
cn ModuleName
m) = (ComponentName -> FilePath
dispCName ComponentName
cn, ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m)
    double (BuildTargetFile ComponentName
cn FilePath
f) = (ComponentName -> FilePath
dispCName ComponentName
cn, FilePath
f)

    triple :: BuildTarget -> (FilePath, FilePath, FilePath)
triple (BuildTargetComponent ComponentName
_) = FilePath -> (FilePath, FilePath, FilePath)
forall a. HasCallStack => FilePath -> a
error FilePath
"triple BuildTargetComponent"
    triple (BuildTargetModule ComponentName
cn ModuleName
m) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn, ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m)
    triple (BuildTargetFile ComponentName
cn FilePath
f) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn, FilePath
f)

    dispCName :: ComponentName -> FilePath
dispCName = PackageId -> ComponentName -> FilePath
forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageId
pkgid
    dispKind :: ComponentName -> FilePath
dispKind = ComponentKind -> FilePath
showComponentKindShort (ComponentKind -> FilePath)
-> (ComponentName -> ComponentKind) -> ComponentName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> ComponentKind
componentKind

reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems Verbosity
verbosity [BuildTargetProblem]
problems = do
  case [(UserBuildTarget
t, [FilePath]
e, FilePath
g) | BuildTargetExpected UserBuildTarget
t [FilePath]
e FilePath
g <- [BuildTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [FilePath], FilePath)]
targets ->
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines
          [ FilePath
"Unrecognised build target '"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'.\n"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Expected a "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" or " [FilePath]
expected
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
", rather than '"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
got
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
          | (UserBuildTarget
target, [FilePath]
expected, FilePath
got) <- [(UserBuildTarget, [FilePath], FilePath)]
targets
          ]

  case [(UserBuildTarget
t, [(FilePath, FilePath)]
e) | BuildTargetNoSuch UserBuildTarget
t [(FilePath, FilePath)]
e <- [BuildTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [(FilePath, FilePath)])]
targets ->
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines
          [ FilePath
"Unknown build target '"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'.\nThere is no "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate
              FilePath
" or "
              [ ShowS
mungeThing FilePath
thing FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" '" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
got FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'"
              | (FilePath
thing, FilePath
got) <- [(FilePath, FilePath)]
nosuch
              ]
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"."
          | (UserBuildTarget
target, [(FilePath, FilePath)]
nosuch) <- [(UserBuildTarget, [(FilePath, FilePath)])]
targets
          ]
      where
        mungeThing :: ShowS
mungeThing FilePath
"file" = FilePath
"file target"
        mungeThing FilePath
thing = FilePath
thing

  case [(UserBuildTarget
t, [(UserBuildTarget, BuildTarget)]
ts) | BuildTargetAmbiguous UserBuildTarget
t [(UserBuildTarget, BuildTarget)]
ts <- [BuildTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets ->
      Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines
          [ FilePath
"Ambiguous build target '"
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'. It could be:\n "
            FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines
              [ FilePath
"   "
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
ut
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" ("
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ BuildTarget -> FilePath
showBuildTargetKind BuildTarget
bt
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
")"
              | (UserBuildTarget
ut, BuildTarget
bt) <- [(UserBuildTarget, BuildTarget)]
amb
              ]
          | (UserBuildTarget
target, [(UserBuildTarget, BuildTarget)]
amb) <- [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets
          ]
  where
    showBuildTargetKind :: BuildTarget -> FilePath
showBuildTargetKind (BuildTargetComponent ComponentName
_) = FilePath
"component"
    showBuildTargetKind (BuildTargetModule ComponentName
_ ModuleName
_) = FilePath
"module"
    showBuildTargetKind (BuildTargetFile ComponentName
_ FilePath
_) = FilePath
"file"

----------------------------------
-- Top level BuildTarget matcher
--

matchBuildTarget
  :: PackageDescription
  -> UserBuildTarget
  -> Bool
  -> Match BuildTarget
matchBuildTarget :: PackageDescription -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget PackageDescription
pkg = \UserBuildTarget
utarget Bool
fexists ->
  case UserBuildTarget
utarget of
    UserBuildTargetSingle FilePath
str1 ->
      [ComponentInfo] -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget1 [ComponentInfo]
cinfo FilePath
str1 Bool
fexists
    UserBuildTargetDouble FilePath
str1 FilePath
str2 ->
      [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists
    UserBuildTargetTriple FilePath
str1 FilePath
str2 FilePath
str3 ->
      [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists
  where
    cinfo :: [ComponentInfo]
cinfo = PackageDescription -> [ComponentInfo]
pkgComponentInfo PackageDescription
pkg

matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 :: [ComponentInfo] -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget1 [ComponentInfo]
cinfo FilePath
str1 Bool
fexists =
  [ComponentInfo] -> FilePath -> Match BuildTarget
matchComponent1 [ComponentInfo]
cinfo FilePath
str1
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> Match BuildTarget
matchModule1 [ComponentInfo]
cinfo FilePath
str1
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> Bool -> Match BuildTarget
matchFile1 [ComponentInfo]
cinfo FilePath
str1 Bool
fexists

matchBuildTarget2
  :: [ComponentInfo]
  -> String
  -> String
  -> Bool
  -> Match BuildTarget
matchBuildTarget2 :: [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists =
  [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchComponent2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchModule2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists

matchBuildTarget3
  :: [ComponentInfo]
  -> String
  -> String
  -> String
  -> Bool
  -> Match BuildTarget
matchBuildTarget3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists =
  [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Match BuildTarget
matchModule3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists

data ComponentInfo = ComponentInfo
  { ComponentInfo -> ComponentName
cinfoName :: ComponentName
  , ComponentInfo -> FilePath
cinfoStrName :: ComponentStringName
  , ComponentInfo -> [FilePath]
cinfoSrcDirs :: [FilePath]
  , ComponentInfo -> [ModuleName]
cinfoModules :: [ModuleName]
  , ComponentInfo -> [FilePath]
cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
  , ComponentInfo -> [FilePath]
cinfoAsmFiles :: [FilePath]
  , ComponentInfo -> [FilePath]
cinfoCmmFiles :: [FilePath]
  , ComponentInfo -> [FilePath]
cinfoCFiles :: [FilePath]
  , ComponentInfo -> [FilePath]
cinfoCxxFiles :: [FilePath]
  , ComponentInfo -> [FilePath]
cinfoJsFiles :: [FilePath]
  }

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo PackageDescription
pkg =
  [ ComponentInfo
    { cinfoName :: ComponentName
cinfoName = Component -> ComponentName
componentName Component
c
    , cinfoStrName :: FilePath
cinfoStrName = PackageDescription -> ComponentName -> FilePath
forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageDescription
pkg (Component -> ComponentName
componentName Component
c)
    , cinfoSrcDirs :: [FilePath]
cinfoSrcDirs = (SymbolicPath PackageDir SourceDir -> FilePath)
-> [SymbolicPath PackageDir SourceDir] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> FilePath
forall from to. SymbolicPath from to -> FilePath
getSymbolicPath ([SymbolicPath PackageDir SourceDir] -> [FilePath])
-> [SymbolicPath PackageDir SourceDir] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi
    , cinfoModules :: [ModuleName]
cinfoModules = Component -> [ModuleName]
componentModules Component
c
    , cinfoHsFiles :: [FilePath]
cinfoHsFiles = Component -> [FilePath]
componentHsFiles Component
c
    , cinfoAsmFiles :: [FilePath]
cinfoAsmFiles = BuildInfo -> [FilePath]
asmSources BuildInfo
bi
    , cinfoCmmFiles :: [FilePath]
cinfoCmmFiles = BuildInfo -> [FilePath]
cmmSources BuildInfo
bi
    , cinfoCFiles :: [FilePath]
cinfoCFiles = BuildInfo -> [FilePath]
cSources BuildInfo
bi
    , cinfoCxxFiles :: [FilePath]
cinfoCxxFiles = BuildInfo -> [FilePath]
cxxSources BuildInfo
bi
    , cinfoJsFiles :: [FilePath]
cinfoJsFiles = BuildInfo -> [FilePath]
jsSources BuildInfo
bi
    }
  | Component
c <- PackageDescription -> [Component]
pkgComponents PackageDescription
pkg
  , let bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
c
  ]

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

componentModules :: Component -> [ModuleName]
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
-- a user could very well ask to build a specific signature
-- that was inherited from other packages.  To fix this
-- we have to plumb 'LocalBuildInfo' through this code.
-- Fortunately, this is only used by 'pkgComponentInfo'
-- Please don't export this function unless you plan on fixing
-- this.
componentModules :: 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 -> [FilePath]
componentHsFiles (CExe Executable
exe) = [Executable -> FilePath
modulePath Executable
exe]
componentHsFiles
  ( CTest
      TestSuite
        { testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ FilePath
mainfile
        }
    ) = [FilePath
mainfile]
componentHsFiles
  ( CBench
      Benchmark
        { benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 Version
_ FilePath
mainfile
        }
    ) = [FilePath
mainfile]
componentHsFiles Component
_ = []

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

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

data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
  deriving (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 -> ShowS
[ComponentKind] -> ShowS
ComponentKind -> FilePath
(Int -> ComponentKind -> ShowS)
-> (ComponentKind -> FilePath)
-> ([ComponentKind] -> ShowS)
-> Show ComponentKind
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComponentKind -> ShowS
showsPrec :: Int -> ComponentKind -> ShowS
$cshow :: ComponentKind -> FilePath
show :: ComponentKind -> FilePath
$cshowList :: [ComponentKind] -> ShowS
showList :: [ComponentKind] -> ShowS
Show, 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, ComponentKind
ComponentKind -> ComponentKind -> Bounded ComponentKind
forall a. a -> a -> Bounded a
$cminBound :: ComponentKind
minBound :: ComponentKind
$cmaxBound :: ComponentKind
maxBound :: ComponentKind
Bounded)

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 :: ComponentInfo -> ComponentKind
cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = ComponentName -> ComponentKind
componentKind (ComponentName -> ComponentKind)
-> (ComponentInfo -> ComponentName)
-> ComponentInfo
-> ComponentKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentInfo -> ComponentName
cinfoName

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

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

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

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

matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 :: [ComponentInfo] -> FilePath -> Match BuildTarget
matchComponent1 [ComponentInfo]
cs = \FilePath
str1 -> do
  FilePath -> Match ()
guardComponentName FilePath
str1
  ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> BuildTarget
BuildTargetComponent (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c))

matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 :: [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchComponent2 [ComponentInfo]
cs = \FilePath
str1 FilePath
str2 -> do
  ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
  FilePath -> Match ()
guardComponentName FilePath
str2
  ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> BuildTarget
BuildTargetComponent (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c))

-- utils:

guardComponentName :: String -> Match ()
guardComponentName :: FilePath -> Match ()
guardComponentName FilePath
s
  | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validComponentChar FilePath
s
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s) =
      Match ()
increaseConfidence
  | Bool
otherwise = FilePath -> FilePath -> Match ()
forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"component name" FilePath
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 :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName :: [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str =
  FilePath -> FilePath -> Match ComponentInfo -> Match ComponentInfo
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"component" FilePath
str (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
    Match ComponentInfo -> Match ComponentInfo
forall a. Match a -> Match a
increaseConfidenceFor (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
      ShowS
-> [(FilePath, ComponentInfo)] -> FilePath -> Match ComponentInfo
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly
        ShowS
caseFold
        [(ComponentInfo -> FilePath
cinfoStrName ComponentInfo
c, ComponentInfo
c) | ComponentInfo
c <- [ComponentInfo]
cs]
        FilePath
str

matchComponentKindAndName
  :: [ComponentInfo]
  -> ComponentKind
  -> String
  -> Match ComponentInfo
matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str =
  FilePath -> FilePath -> Match ComponentInfo -> Match ComponentInfo
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing (ComponentKind -> FilePath
showComponentKind ComponentKind
ckind FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" component") FilePath
str (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
    Match ComponentInfo -> Match ComponentInfo
forall a. Match a -> Match a
increaseConfidenceFor (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
      ((ComponentKind, FilePath) -> (ComponentKind, FilePath))
-> [((ComponentKind, FilePath), ComponentInfo)]
-> (ComponentKind, FilePath)
-> Match ComponentInfo
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly
        (\(ComponentKind
ck, FilePath
cn) -> (ComponentKind
ck, ShowS
caseFold FilePath
cn))
        [((ComponentInfo -> ComponentKind
cinfoKind ComponentInfo
c, ComponentInfo -> FilePath
cinfoStrName ComponentInfo
c), ComponentInfo
c) | ComponentInfo
c <- [ComponentInfo]
cs]
        (ComponentKind
ckind, FilePath
str)

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

matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 :: [ComponentInfo] -> FilePath -> Match BuildTarget
matchModule1 [ComponentInfo]
cs = \FilePath
str1 -> do
  FilePath -> Match ()
guardModuleName FilePath
str1
  Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a
nubMatchErrors (Match BuildTarget -> Match BuildTarget)
-> Match BuildTarget -> Match BuildTarget
forall a b. (a -> b) -> a -> b
$ do
    ComponentInfo
c <- [ComponentInfo] -> Match ComponentInfo
forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
    let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str1
    BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchModule2 :: [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchModule2 [ComponentInfo]
cs = \FilePath
str1 FilePath
str2 -> do
  FilePath -> Match ()
guardComponentName FilePath
str1
  FilePath -> Match ()
guardModuleName FilePath
str2
  ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
  ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str2
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

matchModule3
  :: [ComponentInfo]
  -> String
  -> String
  -> String
  -> Match BuildTarget
matchModule3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Match BuildTarget
matchModule3 [ComponentInfo]
cs FilePath
str1 FilePath
str2 FilePath
str3 = do
  ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
  FilePath -> Match ()
guardComponentName FilePath
str2
  ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
  FilePath -> Match ()
guardModuleName FilePath
str3
  let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
  ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str3
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

-- utils:

guardModuleName :: String -> Match ()
guardModuleName :: FilePath -> Match ()
guardModuleName FilePath
s
  | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar FilePath
s
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s) =
      Match ()
increaseConfidence
  | Bool
otherwise = FilePath -> FilePath -> Match ()
forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"module name" FilePath
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] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str =
  FilePath -> FilePath -> Match ModuleName -> Match ModuleName
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"module" FilePath
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
$
      ShowS -> [(FilePath, ModuleName)] -> FilePath -> Match ModuleName
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly
        ShowS
caseFold
        [ (ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m, ModuleName
m)
        | ModuleName
m <- [ModuleName]
ms
        ]
        FilePath
str

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

matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 :: [ComponentInfo] -> FilePath -> Bool -> Match BuildTarget
matchFile1 [ComponentInfo]
cs FilePath
str1 Bool
exists =
  Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a
nubMatchErrors (Match BuildTarget -> Match BuildTarget)
-> Match BuildTarget -> Match BuildTarget
forall a b. (a -> b) -> a -> b
$ do
    ComponentInfo
c <- [ComponentInfo] -> Match ComponentInfo
forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
    FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str1 Bool
exists
    BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)

matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 :: [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile2 [ComponentInfo]
cs FilePath
str1 FilePath
str2 Bool
exists = do
  FilePath -> Match ()
guardComponentName FilePath
str1
  ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str2 Bool
exists
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)

matchFile3
  :: [ComponentInfo]
  -> String
  -> String
  -> String
  -> Bool
  -> Match BuildTarget
matchFile3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile3 [ComponentInfo]
cs FilePath
str1 FilePath
str2 FilePath
str3 Bool
exists = do
  ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
  FilePath -> Match ()
guardComponentName FilePath
str2
  ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
  FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str3 Bool
exists
  BuildTarget -> Match BuildTarget
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)

matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile :: ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str Bool
fexists =
  FilePath -> FilePath -> Match FilePath -> Match FilePath
forall a. FilePath -> FilePath -> Match a -> Match a
expecting FilePath
"file" FilePath
str (Match FilePath -> Match FilePath)
-> Match FilePath -> Match FilePath
forall a b. (a -> b) -> a -> b
$
    Match FilePath -> Match FilePath -> Match FilePath
forall a. Match a -> Match a -> Match a
matchPlus
      (FilePath -> Bool -> Match FilePath
forall a. FilePath -> Bool -> Match a
matchFileExists FilePath
str Bool
fexists)
      ( Match FilePath -> Match FilePath -> Match FilePath
forall a. Match a -> Match a -> Match a
matchPlusShadowing
          ( [Match FilePath] -> Match FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
              [ [FilePath] -> [ModuleName] -> FilePath -> Match FilePath
matchModuleFileRooted [FilePath]
dirs [ModuleName]
ms FilePath
str
              , [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted [FilePath]
dirs [FilePath]
hsFiles FilePath
str
              ]
          )
          ( [Match FilePath] -> Match FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
              [ [ModuleName] -> FilePath -> Match FilePath
matchModuleFileUnrooted [ModuleName]
ms FilePath
str
              , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted [FilePath]
hsFiles FilePath
str
              , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted [FilePath]
cFiles FilePath
str
              , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted [FilePath]
jsFiles FilePath
str
              ]
          )
      )
  where
    dirs :: [FilePath]
dirs = ComponentInfo -> [FilePath]
cinfoSrcDirs ComponentInfo
c
    ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    hsFiles :: [FilePath]
hsFiles = ComponentInfo -> [FilePath]
cinfoHsFiles ComponentInfo
c
    cFiles :: [FilePath]
cFiles = ComponentInfo -> [FilePath]
cinfoCFiles ComponentInfo
c
    jsFiles :: [FilePath]
jsFiles = ComponentInfo -> [FilePath]
cinfoJsFiles ComponentInfo
c

-- utils

matchFileExists :: FilePath -> Bool -> Match a
matchFileExists :: forall a. FilePath -> Bool -> Match a
matchFileExists FilePath
_ Bool
False = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
matchFileExists FilePath
fname Bool
True = do
  Match ()
increaseConfidence
  FilePath -> FilePath -> Match a
forall a. FilePath -> FilePath -> Match a
matchErrorNoSuch FilePath
"file" FilePath
fname

matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted :: [ModuleName] -> FilePath -> Match FilePath
matchModuleFileUnrooted [ModuleName]
ms FilePath
str = do
  let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
  ModuleName
_ <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms FilePath
filepath
  FilePath -> Match FilePath
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted :: [FilePath] -> [ModuleName] -> FilePath -> Match FilePath
matchModuleFileRooted [FilePath]
dirs [ModuleName]
ms FilePath
str = Match FilePath -> Match FilePath
forall a. Eq a => Match a -> Match a
nubMatches (Match FilePath -> Match FilePath)
-> Match FilePath -> Match FilePath
forall a b. (a -> b) -> a -> b
$ do
  let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
  FilePath
filepath' <- [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath
  ModuleName
_ <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms FilePath
filepath'
  FilePath -> Match FilePath
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms =
  Match ModuleName -> Match ModuleName
forall a. Match a -> Match a
increaseConfidenceFor
    (Match ModuleName -> Match ModuleName)
-> (FilePath -> Match ModuleName) -> FilePath -> Match ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [(FilePath, ModuleName)] -> FilePath -> Match ModuleName
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly
      ShowS
caseFold
      [(ModuleName -> FilePath
toFilePath ModuleName
m, ModuleName
m) | ModuleName
m <- [ModuleName]
ms]
    (FilePath -> Match ModuleName)
-> ShowS -> FilePath -> Match ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropExtension

matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted [FilePath]
dirs [FilePath]
fs FilePath
str = do
  let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
  FilePath
filepath' <- [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath
  FilePath
_ <- [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs FilePath
filepath'
  FilePath -> Match FilePath
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted [FilePath]
fs FilePath
str = do
  let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
  FilePath
_ <- [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs FilePath
filepath
  FilePath -> Match FilePath
forall {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

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

matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath =
  [FilePath] -> Match FilePath
forall a. [a] -> Match a
exactMatches ([FilePath] -> Match FilePath) -> [FilePath] -> Match FilePath
forall a b. (a -> b) -> a -> b
$
    [Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes
      [FilePath -> FilePath -> Maybe FilePath
stripDirectory (ShowS
normalise FilePath
dir) FilePath
filepath | FilePath
dir <- [FilePath]
dirs]
  where
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
stripDirectory FilePath
dir FilePath
fp =
      [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [FilePath] -> [FilePath] -> Maybe [FilePath]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (FilePath -> [FilePath]
splitDirectories FilePath
dir) (FilePath -> [FilePath]
splitDirectories FilePath
fp)

------------------------------
-- Matching monad
--

-- | A matcher embodies a way to match some input as being some recognised
-- value. In particular it deals with multiple and ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
data Match a
  = NoMatch Confidence [MatchError]
  | ExactMatch Confidence [a]
  | InexactMatch Confidence [a]
  deriving (Int -> Match a -> ShowS
[Match a] -> ShowS
Match a -> FilePath
(Int -> Match a -> ShowS)
-> (Match a -> FilePath) -> ([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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([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 -> FilePath
show :: Match a -> FilePath
$cshowList :: forall a. Show a => [Match a] -> ShowS
showList :: [Match a] -> ShowS
Show)

type Confidence = Int

data MatchError
  = MatchErrorExpected String String
  | MatchErrorNoSuch String String
  deriving (Int -> MatchError -> ShowS
[MatchError] -> ShowS
MatchError -> FilePath
(Int -> MatchError -> ShowS)
-> (MatchError -> FilePath)
-> ([MatchError] -> ShowS)
-> Show MatchError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchError -> ShowS
showsPrec :: Int -> MatchError -> ShowS
$cshow :: MatchError -> FilePath
show :: MatchError -> FilePath
$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 Alternative Match where
  empty :: forall a. Match a
empty = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall a. Match a -> Match a -> Match a
(<|>) = Match a -> Match a -> Match a
forall a. Match a -> Match a -> Match a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus Match where
  mzero :: forall a. Match a
mzero = Match a
forall a. Match a
matchZero
  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

matchZero :: Match a
matchZero :: forall a. Match a
matchZero = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 []

-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
-- ambiguous matches.
matchPlus :: Match a -> Match a -> Match a
matchPlus :: forall a. Match a -> Match a -> Match a
matchPlus (ExactMatch Int
d1 [a]
xs) (ExactMatch Int
d2 [a]
xs') =
  Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs')
matchPlus a :: Match a
a@(ExactMatch Int
_ [a]
_) (InexactMatch Int
_ [a]
_) = Match a
a
matchPlus a :: Match a
a@(ExactMatch Int
_ [a]
_) (NoMatch Int
_ [MatchError]
_) = Match a
a
matchPlus (InexactMatch Int
_ [a]
_) b :: Match a
b@(ExactMatch Int
_ [a]
_) = Match a
b
matchPlus (InexactMatch Int
d1 [a]
xs) (InexactMatch Int
d2 [a]
xs') =
  Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs')
matchPlus a :: Match a
a@(InexactMatch Int
_ [a]
_) (NoMatch Int
_ [MatchError]
_) = Match a
a
matchPlus (NoMatch Int
_ [MatchError]
_) b :: Match a
b@(ExactMatch Int
_ [a]
_) = Match a
b
matchPlus (NoMatch Int
_ [MatchError]
_) b :: Match a
b@(InexactMatch Int
_ [a]
_) = Match a
b
matchPlus a :: Match a
a@(NoMatch Int
d1 [MatchError]
ms) b :: Match a
b@(NoMatch Int
d2 [MatchError]
ms')
  | Int
d1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
d2 = Match a
a
  | Int
d1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d2 = Match a
b
  | Bool
otherwise = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d1 ([MatchError]
ms [MatchError] -> [MatchError] -> [MatchError]
forall a. [a] -> [a] -> [a]
++ [MatchError]
ms')

-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing :: forall a. Match a -> Match a -> Match a
matchPlusShadowing a :: Match a
a@(ExactMatch Int
_ [a]
_) (ExactMatch Int
_ [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

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 (ExactMatch Int
d [a]
xs) = Int -> [b] -> Match b
forall a. Int -> [a] -> Match a
ExactMatch 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)
  fmap a -> b
f (InexactMatch Int
d [a]
xs) = Int -> [b] -> Match b
forall a. Int -> [a] -> Match a
InexactMatch 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 {b}. b -> Match b
pure a
a = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch 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 Monad Match where
  return :: forall {b}. b -> Match b
return = a -> Match a
forall {b}. b -> Match b
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
  ExactMatch Int
d [a]
xs >>= a -> Match b
f =
    Int -> Match b -> Match b
forall a. Int -> Match a -> Match a
addDepth Int
d (Match b -> Match b) -> Match b -> Match b
forall a b. (a -> b) -> a -> b
$
      (Match b -> Match b -> Match b) -> Match b -> [Match b] -> Match b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Match b -> Match b -> Match b
forall a. Match a -> Match a -> Match a
matchPlus Match b
forall a. Match a
matchZero ((a -> Match b) -> [a] -> [Match b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs)
  InexactMatch Int
d [a]
xs >>= a -> Match b
f =
    Int -> Match b -> Match b
forall a. Int -> Match a -> Match a
addDepth Int
d (Match b -> Match b) -> (Match b -> Match b) -> Match b -> Match b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match b -> Match b
forall a. Match a -> Match a
forceInexact (Match b -> Match b) -> Match b -> Match b
forall a b. (a -> b) -> a -> b
$
      (Match b -> Match b -> Match b) -> Match b -> [Match b] -> Match b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Match b -> Match b -> Match b
forall a. Match a -> Match a -> Match a
matchPlus Match b
forall a. Match a
matchZero ((a -> Match b) -> [a] -> [Match b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs)

addDepth :: Confidence -> Match a -> Match a
addDepth :: forall a. Int -> Match a -> Match a
addDepth Int
d' (NoMatch Int
d [MatchError]
msgs) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch (Int
d' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) [MatchError]
msgs
addDepth Int
d' (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch (Int
d' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) [a]
xs
addDepth Int
d' (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch (Int
d' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) [a]
xs

forceInexact :: Match a -> Match a
forceInexact :: forall a. Match a -> Match a
forceInexact (ExactMatch Int
d [a]
ys) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d [a]
ys
forceInexact Match a
m = Match a
m

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

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

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

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

increaseConfidence :: Match ()
increaseConfidence :: Match ()
increaseConfidence = Int -> [()] -> Match ()
forall a. Int -> [a] -> Match a
ExactMatch 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 {b}. b -> Match b
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

nubMatches :: Eq a => Match a -> Match a
nubMatches :: forall a. Eq a => Match a -> Match a
nubMatches (NoMatch Int
d [MatchError]
msgs) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
msgs
nubMatches (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
d ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs)
nubMatches (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs)

nubMatchErrors :: Match a -> Match a
nubMatchErrors :: forall a. Match a -> Match a
nubMatchErrors (NoMatch Int
d [MatchError]
msgs) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d ([MatchError] -> [MatchError]
forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
nubMatchErrors (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
d [a]
xs
nubMatchErrors (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d [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
matchZero
exactMatches [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a]
xs
inexactMatches :: forall a. [a] -> Match a
inexactMatches [] = Match a
forall a. Match a
matchZero
inexactMatches [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
0 [a]
xs

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 :: Eq b => Match b -> MaybeAmbiguous b
findMatch :: forall b. Eq b => Match b -> MaybeAmbiguous b
findMatch Match b
match =
  case Match b
match of
    NoMatch Int
_ [MatchError]
msgs -> [MatchError] -> MaybeAmbiguous b
forall a. [MatchError] -> MaybeAmbiguous a
None ([MatchError] -> [MatchError]
forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
    ExactMatch Int
_ [b]
xs -> [b] -> MaybeAmbiguous b
forall {a}. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
    InexactMatch Int
_ [b]
xs -> [b] -> MaybeAmbiguous b
forall {a}. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
  where
    checkAmbiguous :: [a] -> MaybeAmbiguous a
checkAmbiguous [a]
xs = case [a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs of
      [a
x] -> a -> MaybeAmbiguous a
forall a. a -> MaybeAmbiguous a
Unambiguous a
x
      [a]
xs' -> [a] -> MaybeAmbiguous a
forall a. [a] -> MaybeAmbiguous a
Ambiguous [a]
xs'

data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
  deriving (Int -> MaybeAmbiguous a -> ShowS
[MaybeAmbiguous a] -> ShowS
MaybeAmbiguous a -> FilePath
(Int -> MaybeAmbiguous a -> ShowS)
-> (MaybeAmbiguous a -> FilePath)
-> ([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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([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 -> FilePath
show :: MaybeAmbiguous a -> FilePath
$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 :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
matchExactly xs =
    \x -> case Map.lookup x m of
            Nothing -> matchZero
            Just ys -> ExactMatch 0 ys
  where
    m :: Ord a => Map a [b]
    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
-}

-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
-- is not exact, but the canonical forms match. It takes a canonicalisation
-- function for this purpose.
--
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
matchInexactly
  :: (Ord a, Ord a')
  => (a -> a')
  -> [(a, b)]
  -> (a -> Match b)
matchInexactly :: forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly a -> a'
cannonicalise [(a, b)]
xs =
  \a
x -> case a -> Map a [b] -> Maybe [b]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a [b]
m of
    Just [b]
ys -> [b] -> Match b
forall a. [a] -> Match a
exactMatches [b]
ys
    Maybe [b]
Nothing -> case a' -> Map a' [b] -> Maybe [b]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> a'
cannonicalise a
x) Map a' [b]
m' of
      Just [b]
ys -> [b] -> Match b
forall a. [a] -> Match a
inexactMatches [b]
ys
      Maybe [b]
Nothing -> Match b
forall a. Match a
matchZero
  where
    m :: Map a [b]
m = ([b] -> [b] -> [b]) -> [(a, [b])] -> Map a [b]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) [(a
k, [b
x]) | (a
k, b
x) <- [(a, b)]
xs]

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

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

caseFold :: String -> String
caseFold :: ShowS
caseFold = ShowS
lowercase

-- | Check that the given build targets are valid in the current context.
--
-- Also swizzle into a more convenient form.
checkBuildTargets
  :: Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> [BuildTarget]
  -> IO [TargetInfo]
checkBuildTargets :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [BuildTarget]
-> IO [TargetInfo]
checkBuildTargets Verbosity
_ PackageDescription
pkg_descr LocalBuildInfo
lbi [] =
  [TargetInfo] -> IO [TargetInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder' PackageDescription
pkg_descr LocalBuildInfo
lbi)
checkBuildTargets Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi [BuildTarget]
targets = do
  let ([(ComponentName, Maybe (Either ModuleName FilePath))]
enabled, [(ComponentName, ComponentDisabledReason)]
disabled) =
        [Either
   (ComponentName, Maybe (Either ModuleName FilePath))
   (ComponentName, ComponentDisabledReason)]
-> ([(ComponentName, Maybe (Either ModuleName FilePath))],
    [(ComponentName, ComponentDisabledReason)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
          [ case ComponentRequestedSpec
-> Component -> Maybe ComponentDisabledReason
componentDisabledReason (LocalBuildInfo -> ComponentRequestedSpec
componentEnabledSpec LocalBuildInfo
lbi) Component
comp of
            Maybe ComponentDisabledReason
Nothing -> (ComponentName, Maybe (Either ModuleName FilePath))
-> Either
     (ComponentName, Maybe (Either ModuleName FilePath))
     (ComponentName, ComponentDisabledReason)
forall a b. a -> Either a b
Left (ComponentName, Maybe (Either ModuleName FilePath))
target'
            Just ComponentDisabledReason
reason -> (ComponentName, ComponentDisabledReason)
-> Either
     (ComponentName, Maybe (Either ModuleName FilePath))
     (ComponentName, ComponentDisabledReason)
forall a b. b -> Either a b
Right (ComponentName
cname, ComponentDisabledReason
reason)
          | BuildTarget
target <- [BuildTarget]
targets
          , let target' :: (ComponentName, Maybe (Either ModuleName FilePath))
target'@(ComponentName
cname, Maybe (Either ModuleName FilePath)
_) = BuildTarget -> (ComponentName, Maybe (Either ModuleName FilePath))
swizzleTarget BuildTarget
target
          , let comp :: Component
comp = PackageDescription -> ComponentName -> Component
getComponent PackageDescription
pkg_descr ComponentName
cname
          ]

  case [(ComponentName, ComponentDisabledReason)]
disabled of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ((ComponentName
cname, ComponentDisabledReason
reason) : [(ComponentName, ComponentDisabledReason)]
_) -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ComponentDisabledReason -> FilePath
formatReason (ComponentName -> FilePath
showComponentName ComponentName
cname) ComponentDisabledReason
reason

  [(ComponentName, Either ModuleName FilePath)]
-> ((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(ComponentName
c, Either ModuleName FilePath
t) | (ComponentName
c, Just Either ModuleName FilePath
t) <- [(ComponentName, Maybe (Either ModuleName FilePath))]
enabled] (((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ())
-> ((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ComponentName
c, Either ModuleName FilePath
t) ->
    Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"Ignoring '"
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (ModuleName -> FilePath)
-> ShowS -> Either ModuleName FilePath -> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ShowS
forall a. a -> a
id Either ModuleName FilePath
t
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
". The whole "
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> FilePath
showComponentName ComponentName
c
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" will be processed. (Support for "
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"module and file targets has not been implemented yet.)"

  -- Pick out the actual CLBIs for each of these cnames
  [TargetInfo]
enabled' <- [(ComponentName, Maybe (Either ModuleName FilePath))]
-> ((ComponentName, Maybe (Either ModuleName FilePath))
    -> IO TargetInfo)
-> IO [TargetInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ComponentName, Maybe (Either ModuleName FilePath))]
enabled (((ComponentName, Maybe (Either ModuleName FilePath))
  -> IO TargetInfo)
 -> IO [TargetInfo])
-> ((ComponentName, Maybe (Either ModuleName FilePath))
    -> IO TargetInfo)
-> IO [TargetInfo]
forall a b. (a -> b) -> a -> b
$ \(ComponentName
cname, Maybe (Either ModuleName FilePath)
_) -> do
    case PackageDescription
-> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentName
cname of
      [] -> FilePath -> IO TargetInfo
forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: nothing enabled"
      [TargetInfo
target] -> TargetInfo -> IO TargetInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TargetInfo
target
      [TargetInfo]
_targets -> FilePath -> IO TargetInfo
forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: multiple copies enabled"

  [TargetInfo] -> IO [TargetInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [TargetInfo]
enabled'
  where
    swizzleTarget :: BuildTarget -> (ComponentName, Maybe (Either ModuleName FilePath))
swizzleTarget (BuildTargetComponent ComponentName
c) = (ComponentName
c, Maybe (Either ModuleName FilePath)
forall a. Maybe a
Nothing)
    swizzleTarget (BuildTargetModule ComponentName
c ModuleName
m) = (ComponentName
c, Either ModuleName FilePath -> Maybe (Either ModuleName FilePath)
forall a. a -> Maybe a
Just (ModuleName -> Either ModuleName FilePath
forall a b. a -> Either a b
Left ModuleName
m))
    swizzleTarget (BuildTargetFile ComponentName
c FilePath
f) = (ComponentName
c, Either ModuleName FilePath -> Maybe (Either ModuleName FilePath)
forall a. a -> Maybe a
Just (FilePath -> Either ModuleName FilePath
forall a b. b -> Either a b
Right FilePath
f))

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