{-# LANGUAGE OverloadedStrings #-}

{- | Static, no-compile discovery of a Haskell repository's cabal projects,
packages and test suites.

This is a native port of @scripts\/list-test-suites\/list-test-suites.sh@. It
emits the same JSON document, validating against that tool's
@list-test-suites.schema.json@, so anything already consuming the script's
output can consume @pbt-cli suites --json@ unchanged. The port exists because
the shipped @pbt-cli@ binary must work on its own: a downloaded binary has no
repository checkout to find a bash script in.

Nothing here compiles or even configures anything — it reads @*.cabal@ and
@cabal.project*@ as text, which is why it takes milliseconds.

The one deliberate divergence from the shell implementation: a trailing comma
on a @packages:@ entry is stripped, because @cabal@ itself accepts
comma-separated lists and the shell version would silently drop such a package.
-}
module PbtCli.Discover (
  -- * Types
  Discovery (..),
  Project (..),
  Package (..),
  TestSuite (..),
  Orphan (..),
  EntryPoint (..),
  entryPointText,

  -- * Discovery
  discover,

  -- * Compatibility
  isCompatible,
  compatibleOnly,

  -- * Flattened views
  SuiteRef (..),
  flattenSuites,
  findSuite,

  -- * Reusable pieces
  entryPointOfFile,
  classifySource,
  parseTestSuites,
  packageNameOf,
  projectFilesIn,
  findCabalFiles,
  readFileLenient,
) where

import Control.Exception (evaluate)
import Control.Monad (filterM)
import Data.Aeson (ToJSON (..), object, (.=))
import Data.Char (isAlpha, isSpace, toLower)
import Data.List (dropWhileEnd, foldl', isInfixOf, isPrefixOf, isSuffixOf, sort)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import PbtCli.Glob (expandGlob, isGlob)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute, pathIsSymbolicLink)
import System.FilePath (isAbsolute, splitDirectories, takeDirectory, takeExtension, (</>))
import System.IO (
  IOMode (ReadMode),
  hGetContents,
  hPutStrLn,
  hSetEncoding,
  mkTextEncoding,
  stderr,
  withFile,
 )

-- ---------------------------------------------------------------------------
-- Types
-- ---------------------------------------------------------------------------

{- | How a test suite's @main-is@ module runs its tests.

Only 'Streaming' suites provide the @--streaming-json@ and @--list-tests-json@
ingredients, because those come from the @convex-tasty-streaming@ library. That
makes 'Streaming' the operational definition of "sc-testing-tools compatible".
-}
data EntryPoint
  = -- | @defaultMainStreaming@ and friends: structured discovery and streaming.
    Streaming
  | -- | plain @Test.Tasty.defaultMain@: runnable, but no structured output.
    Upstream
  | -- | a @main-is@ module with no recognised runner.
    UnknownEntry
  | -- | the @main-is@ source file was not found on disk.
    MissingEntry
  deriving (EntryPoint -> EntryPoint -> Bool
(EntryPoint -> EntryPoint -> Bool)
-> (EntryPoint -> EntryPoint -> Bool) -> Eq EntryPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EntryPoint -> EntryPoint -> Bool
== :: EntryPoint -> EntryPoint -> Bool
$c/= :: EntryPoint -> EntryPoint -> Bool
/= :: EntryPoint -> EntryPoint -> Bool
Eq, Eq EntryPoint
Eq EntryPoint =>
(EntryPoint -> EntryPoint -> Ordering)
-> (EntryPoint -> EntryPoint -> Bool)
-> (EntryPoint -> EntryPoint -> Bool)
-> (EntryPoint -> EntryPoint -> Bool)
-> (EntryPoint -> EntryPoint -> Bool)
-> (EntryPoint -> EntryPoint -> EntryPoint)
-> (EntryPoint -> EntryPoint -> EntryPoint)
-> Ord EntryPoint
EntryPoint -> EntryPoint -> Bool
EntryPoint -> EntryPoint -> Ordering
EntryPoint -> EntryPoint -> EntryPoint
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 :: EntryPoint -> EntryPoint -> Ordering
compare :: EntryPoint -> EntryPoint -> Ordering
$c< :: EntryPoint -> EntryPoint -> Bool
< :: EntryPoint -> EntryPoint -> Bool
$c<= :: EntryPoint -> EntryPoint -> Bool
<= :: EntryPoint -> EntryPoint -> Bool
$c> :: EntryPoint -> EntryPoint -> Bool
> :: EntryPoint -> EntryPoint -> Bool
$c>= :: EntryPoint -> EntryPoint -> Bool
>= :: EntryPoint -> EntryPoint -> Bool
$cmax :: EntryPoint -> EntryPoint -> EntryPoint
max :: EntryPoint -> EntryPoint -> EntryPoint
$cmin :: EntryPoint -> EntryPoint -> EntryPoint
min :: EntryPoint -> EntryPoint -> EntryPoint
Ord, Int -> EntryPoint -> ShowS
[EntryPoint] -> ShowS
EntryPoint -> FilePath
(Int -> EntryPoint -> ShowS)
-> (EntryPoint -> FilePath)
-> ([EntryPoint] -> ShowS)
-> Show EntryPoint
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EntryPoint -> ShowS
showsPrec :: Int -> EntryPoint -> ShowS
$cshow :: EntryPoint -> FilePath
show :: EntryPoint -> FilePath
$cshowList :: [EntryPoint] -> ShowS
showList :: [EntryPoint] -> ShowS
Show)

instance ToJSON EntryPoint where
  toJSON :: EntryPoint -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (EntryPoint -> Text) -> EntryPoint -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntryPoint -> Text
entryPointText

-- | The wire name, as it appears in the JSON and in @--tsv@ output.
entryPointText :: EntryPoint -> Text
entryPointText :: EntryPoint -> Text
entryPointText = \case
  EntryPoint
Streaming -> Text
"STREAMING"
  EntryPoint
Upstream -> Text
"upstream"
  EntryPoint
UnknownEntry -> Text
"unknown"
  EntryPoint
MissingEntry -> Text
"MISSING"

-- | A single @test-suite@ stanza, with the commands that drive it.
data TestSuite = TestSuite
  { TestSuite -> Text
tsName :: Text
  -- ^ the stanza name, which is also the @cabal test@ target.
  , TestSuite -> Text
tsMainIs :: Text
  -- ^ @main-is@ relative to the package dir, or the literal @"MISSING"@.
  , TestSuite -> EntryPoint
tsEntryPoint :: EntryPoint
  , TestSuite -> Text
tsRunTestsCommand :: Text
  -- ^ always present.
  , TestSuite -> Maybe Text
tsStreamTestsCommand :: Maybe Text
  -- ^ 'Streaming' suites only.
  , TestSuite -> Maybe Text
tsDiscoverCommand :: Maybe Text
  -- ^ 'Streaming' suites only.
  , TestSuite -> [Text]
tsHsSourceDirs :: [Text]
  -- ^ as written in the stanza, order preserved; @["."]@ when absent.
  }
  deriving (TestSuite -> TestSuite -> Bool
(TestSuite -> TestSuite -> Bool)
-> (TestSuite -> TestSuite -> Bool) -> Eq TestSuite
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestSuite -> TestSuite -> Bool
== :: TestSuite -> TestSuite -> Bool
$c/= :: TestSuite -> TestSuite -> Bool
/= :: TestSuite -> TestSuite -> Bool
Eq, Int -> TestSuite -> ShowS
[TestSuite] -> ShowS
TestSuite -> FilePath
(Int -> TestSuite -> ShowS)
-> (TestSuite -> FilePath)
-> ([TestSuite] -> ShowS)
-> Show TestSuite
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSuite -> ShowS
showsPrec :: Int -> TestSuite -> ShowS
$cshow :: TestSuite -> FilePath
show :: TestSuite -> FilePath
$cshowList :: [TestSuite] -> ShowS
showList :: [TestSuite] -> ShowS
Show)

instance ToJSON TestSuite where
  toJSON :: TestSuite -> Value
toJSON TestSuite
ts =
    [Pair] -> Value
object
      [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> Text
tsName TestSuite
ts
      , Key
"mainIs" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> Text
tsMainIs TestSuite
ts
      , Key
"entryPoint" Key -> EntryPoint -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> EntryPoint
tsEntryPoint TestSuite
ts
      , Key
"runTestsCommand" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> Text
tsRunTestsCommand TestSuite
ts
      , Key
"streamTestsCommand" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> Maybe Text
tsStreamTestsCommand TestSuite
ts
      , Key
"discoverCommand" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> Maybe Text
tsDiscoverCommand TestSuite
ts
      , Key
"hsSourceDirs" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TestSuite -> [Text]
tsHsSourceDirs TestSuite
ts
      ]

-- | A package, rendered under exactly one project (see 'primaryOwner').
data Package = Package
  { Package -> Text
pkgName :: Text
  , Package -> FilePath
pkgCabalFile :: FilePath
  -- ^ relative to the scanned root.
  , Package -> FilePath
pkgPackageDir :: FilePath
  -- ^ relative to the scanned root.
  , Package -> [TestSuite]
pkgTestSuites :: [TestSuite]
  -- ^ empty when the package declares none.
  }
  deriving (Package -> Package -> Bool
(Package -> Package -> Bool)
-> (Package -> Package -> Bool) -> Eq Package
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
/= :: Package -> Package -> Bool
Eq, Int -> Package -> ShowS
[Package] -> ShowS
Package -> FilePath
(Int -> Package -> ShowS)
-> (Package -> FilePath) -> ([Package] -> ShowS) -> Show Package
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Package -> ShowS
showsPrec :: Int -> Package -> ShowS
$cshow :: Package -> FilePath
show :: Package -> FilePath
$cshowList :: [Package] -> ShowS
showList :: [Package] -> ShowS
Show)

instance ToJSON Package where
  toJSON :: Package -> Value
toJSON Package
p =
    [Pair] -> Value
object
      [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Package -> Text
pkgName Package
p
      , Key
"cabalFile" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Package -> FilePath
pkgCabalFile Package
p
      , Key
"packageDir" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Package -> FilePath
pkgPackageDir Package
p
      , Key
"testSuites" Key -> [TestSuite] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Package -> [TestSuite]
pkgTestSuites Package
p
      ]

-- | One @cabal.project*@ file, or the implicit project when there is none.
data Project = Project
  { Project -> Maybe FilePath
projProjectFile :: Maybe FilePath
  {- ^ 'Nothing' is the synthetic project used when the repo has no
  @cabal.project@ at all.
  -}
  , Project -> [Package]
projPackages :: [Package]
  }
  deriving (Project -> Project -> Bool
(Project -> Project -> Bool)
-> (Project -> Project -> Bool) -> Eq Project
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Project -> Project -> Bool
== :: Project -> Project -> Bool
$c/= :: Project -> Project -> Bool
/= :: Project -> Project -> Bool
Eq, Int -> Project -> ShowS
[Project] -> ShowS
Project -> FilePath
(Int -> Project -> ShowS)
-> (Project -> FilePath) -> ([Project] -> ShowS) -> Show Project
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Project -> ShowS
showsPrec :: Int -> Project -> ShowS
$cshow :: Project -> FilePath
show :: Project -> FilePath
$cshowList :: [Project] -> ShowS
showList :: [Project] -> ShowS
Show)

instance ToJSON Project where
  toJSON :: Project -> Value
toJSON Project
p =
    [Pair] -> Value
object
      [ Key
"projectFile" Key -> Maybe FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Project -> Maybe FilePath
projProjectFile Project
p
      , Key
"packages" Key -> [Package] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Project -> [Package]
projPackages Project
p
      ]

-- | A @.cabal@ file no project's @packages:@ field reaches.
data Orphan = Orphan
  { Orphan -> FilePath
orphCabalFile :: FilePath
  , Orphan -> FilePath
orphPackageDir :: FilePath
  }
  deriving (Orphan -> Orphan -> Bool
(Orphan -> Orphan -> Bool)
-> (Orphan -> Orphan -> Bool) -> Eq Orphan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Orphan -> Orphan -> Bool
== :: Orphan -> Orphan -> Bool
$c/= :: Orphan -> Orphan -> Bool
/= :: Orphan -> Orphan -> Bool
Eq, Int -> Orphan -> ShowS
[Orphan] -> ShowS
Orphan -> FilePath
(Int -> Orphan -> ShowS)
-> (Orphan -> FilePath) -> ([Orphan] -> ShowS) -> Show Orphan
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Orphan -> ShowS
showsPrec :: Int -> Orphan -> ShowS
$cshow :: Orphan -> FilePath
show :: Orphan -> FilePath
$cshowList :: [Orphan] -> ShowS
showList :: [Orphan] -> ShowS
Show)

instance ToJSON Orphan where
  toJSON :: Orphan -> Value
toJSON Orphan
o =
    [Pair] -> Value
object
      [ Key
"cabalFile" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Orphan -> FilePath
orphCabalFile Orphan
o
      , Key
"packageDir" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Orphan -> FilePath
orphPackageDir Orphan
o
      ]

-- | The whole discovery result.
data Discovery = Discovery
  { Discovery -> FilePath
discRoot :: FilePath
  -- ^ absolute path of the scanned root.
  , Discovery -> [Project]
discProjects :: [Project]
  , Discovery -> [Orphan]
discOrphans :: [Orphan]
  }
  deriving (Discovery -> Discovery -> Bool
(Discovery -> Discovery -> Bool)
-> (Discovery -> Discovery -> Bool) -> Eq Discovery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Discovery -> Discovery -> Bool
== :: Discovery -> Discovery -> Bool
$c/= :: Discovery -> Discovery -> Bool
/= :: Discovery -> Discovery -> Bool
Eq, Int -> Discovery -> ShowS
[Discovery] -> ShowS
Discovery -> FilePath
(Int -> Discovery -> ShowS)
-> (Discovery -> FilePath)
-> ([Discovery] -> ShowS)
-> Show Discovery
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Discovery -> ShowS
showsPrec :: Int -> Discovery -> ShowS
$cshow :: Discovery -> FilePath
show :: Discovery -> FilePath
$cshowList :: [Discovery] -> ShowS
showList :: [Discovery] -> ShowS
Show)

instance ToJSON Discovery where
  toJSON :: Discovery -> Value
toJSON Discovery
d =
    [Pair] -> Value
object
      [ Key
"root" Key -> FilePath -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Discovery -> FilePath
discRoot Discovery
d
      , Key
"projects" Key -> [Project] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Discovery -> [Project]
discProjects Discovery
d
      , Key
"orphans" Key -> [Orphan] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Discovery -> [Orphan]
discOrphans Discovery
d
      ]

-- ---------------------------------------------------------------------------
-- Compatibility
-- ---------------------------------------------------------------------------

{- | Is this suite sc-testing-tools compatible — that is, does it support
@--list-tests-json@, @--streaming-json@ and the threat-model options?
-}
isCompatible :: TestSuite -> Bool
isCompatible :: TestSuite -> Bool
isCompatible TestSuite
ts = TestSuite -> EntryPoint
tsEntryPoint TestSuite
ts EntryPoint -> EntryPoint -> Bool
forall a. Eq a => a -> a -> Bool
== EntryPoint
Streaming

{- | Drop every non-'Streaming' suite, and then every package and project left
without suites. Used by @--compatible-only@.
-}
compatibleOnly :: Discovery -> Discovery
compatibleOnly :: Discovery -> Discovery
compatibleOnly Discovery
d =
  Discovery
d
    { discProjects =
        [ proj{projPackages = keptPackages}
        | proj <- discProjects d
        , let keptPackages =
                [ Package
pkg{pkgTestSuites = kept}
                | Package
pkg <- Project -> [Package]
projPackages Project
proj
                , let kept :: [TestSuite]
kept = (TestSuite -> Bool) -> [TestSuite] -> [TestSuite]
forall a. (a -> Bool) -> [a] -> [a]
filter TestSuite -> Bool
isCompatible (Package -> [TestSuite]
pkgTestSuites Package
pkg)
                , Bool -> Bool
not ([TestSuite] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestSuite]
kept)
                ]
        , not (null keptPackages)
        ]
    }

-- ---------------------------------------------------------------------------
-- Flattened view
-- ---------------------------------------------------------------------------

{- | A suite together with the context needed to actually run it: which project
file owns it and which package it lives in.

The JSON document is intentionally nested (and its schema forbids extra
fields), so this flattened view is what the @run@ / @stream@ / @tests@
commands work with.
-}
data SuiteRef = SuiteRef
  { SuiteRef -> TestSuite
srSuite :: TestSuite
  , SuiteRef -> Maybe FilePath
srProjectFile :: Maybe FilePath
  -- ^ 'Nothing' means the default project: pass no @--project-file@.
  , SuiteRef -> Text
srPackage :: Text
  , SuiteRef -> FilePath
srPackageDir :: FilePath
  }
  deriving (SuiteRef -> SuiteRef -> Bool
(SuiteRef -> SuiteRef -> Bool)
-> (SuiteRef -> SuiteRef -> Bool) -> Eq SuiteRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SuiteRef -> SuiteRef -> Bool
== :: SuiteRef -> SuiteRef -> Bool
$c/= :: SuiteRef -> SuiteRef -> Bool
/= :: SuiteRef -> SuiteRef -> Bool
Eq, Int -> SuiteRef -> ShowS
[SuiteRef] -> ShowS
SuiteRef -> FilePath
(Int -> SuiteRef -> ShowS)
-> (SuiteRef -> FilePath) -> ([SuiteRef] -> ShowS) -> Show SuiteRef
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SuiteRef -> ShowS
showsPrec :: Int -> SuiteRef -> ShowS
$cshow :: SuiteRef -> FilePath
show :: SuiteRef -> FilePath
$cshowList :: [SuiteRef] -> ShowS
showList :: [SuiteRef] -> ShowS
Show)

{- | Every suite in the discovery, in document order, paired with its project
file and package.

@srProjectFile@ is 'Nothing' both for the implicit project and for the default
@cabal.project@, because in either case @cabal@ needs no @--project-file@ flag.
-}
flattenSuites :: Discovery -> [SuiteRef]
flattenSuites :: Discovery -> [SuiteRef]
flattenSuites Discovery
d =
  [ SuiteRef
      { srSuite :: TestSuite
srSuite = TestSuite
ts
      , srProjectFile :: Maybe FilePath
srProjectFile = Maybe FilePath -> Maybe FilePath
nonDefaultProject (Project -> Maybe FilePath
projProjectFile Project
proj)
      , srPackage :: Text
srPackage = Package -> Text
pkgName Package
pkg
      , srPackageDir :: FilePath
srPackageDir = Package -> FilePath
pkgPackageDir Package
pkg
      }
  | Project
proj <- Discovery -> [Project]
discProjects Discovery
d
  , Package
pkg <- Project -> [Package]
projPackages Project
proj
  , TestSuite
ts <- Package -> [TestSuite]
pkgTestSuites Package
pkg
  ]

-- | Look a suite up by its @cabal test@ target name.
findSuite :: Text -> Discovery -> Maybe SuiteRef
findSuite :: Text -> Discovery -> Maybe SuiteRef
findSuite Text
name = [SuiteRef] -> Maybe SuiteRef
forall a. [a] -> Maybe a
listToMaybe ([SuiteRef] -> Maybe SuiteRef)
-> (Discovery -> [SuiteRef]) -> Discovery -> Maybe SuiteRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SuiteRef -> Bool) -> [SuiteRef] -> [SuiteRef]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool) -> (SuiteRef -> Text) -> SuiteRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> Text
tsName (TestSuite -> Text) -> (SuiteRef -> TestSuite) -> SuiteRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuiteRef -> TestSuite
srSuite) ([SuiteRef] -> [SuiteRef])
-> (Discovery -> [SuiteRef]) -> Discovery -> [SuiteRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Discovery -> [SuiteRef]
flattenSuites

nonDefaultProject :: Maybe FilePath -> Maybe FilePath
nonDefaultProject :: Maybe FilePath -> Maybe FilePath
nonDefaultProject = \case
  Maybe FilePath
Nothing -> Maybe FilePath
forall a. Maybe a
Nothing
  Just FilePath
"cabal.project" -> Maybe FilePath
forall a. Maybe a
Nothing
  Just FilePath
other -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
other

-- ---------------------------------------------------------------------------
-- Entry point
-- ---------------------------------------------------------------------------

{- | Scan @root@ and report every project, package and test suite.

Warnings (orphan @.cabal@ files, packages claimed by several non-default
projects) go to stderr, matching the shell tool, so stdout stays a single
parseable JSON document.
-}
discover :: FilePath -> IO Discovery
discover :: FilePath -> IO Discovery
discover FilePath
root0 = do
  FilePath
root <- FilePath -> IO FilePath
makeAbsolute FilePath
root0
  [FilePath]
walked <- FilePath -> IO [FilePath]
findCabalFiles FilePath
root
  [FilePath]
projectRels <- FilePath -> IO [FilePath]
projectFilesIn FilePath
root

  Map FilePath [FilePath]
owners <-
    if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
projectRels
      then -- No cabal.project anywhere: one synthetic project owns everything.
        Map FilePath [FilePath] -> IO (Map FilePath [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(FilePath, [FilePath])] -> Map FilePath [FilePath]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FilePath
c, [FilePath
implicitProject]) | FilePath
c <- [FilePath]
walked])
      else
        (Map FilePath [FilePath]
 -> Map FilePath [FilePath] -> Map FilePath [FilePath])
-> Map FilePath [FilePath]
-> [Map FilePath [FilePath]]
-> Map FilePath [FilePath]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map FilePath [FilePath]
acc Map FilePath [FilePath]
m -> ([FilePath] -> [FilePath] -> [FilePath])
-> Map FilePath [FilePath]
-> Map FilePath [FilePath]
-> Map FilePath [FilePath]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [FilePath] -> [FilePath] -> [FilePath]
forall {a}. Eq a => [a] -> [a] -> [a]
laterOwnersLast Map FilePath [FilePath]
m Map FilePath [FilePath]
acc) Map FilePath [FilePath]
forall k a. Map k a
Map.empty
          ([Map FilePath [FilePath]] -> Map FilePath [FilePath])
-> IO [Map FilePath [FilePath]] -> IO (Map FilePath [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Map FilePath [FilePath]))
-> [FilePath] -> IO [Map FilePath [FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> FilePath -> IO (Map FilePath [FilePath])
ownersOfProject FilePath
root) [FilePath]
projectRels

  -- The walk is a heuristic search and does not follow symlinks (see
  -- 'findCabalFiles'); a `packages:` entry is an explicit instruction, so a
  -- package it names is honoured even where the walk could not reach it -- a
  -- symlinked package directory being the case that matters. Only paths under
  -- the root are taken: this tool's whole contract is paths relative to the
  -- scanned root, and a `packages: ../elsewhere` entry has none.
  let projectOrder :: [FilePath]
projectOrder = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
projectRels then [FilePath
implicitProject] else [FilePath]
projectRels
      named :: [FilePath]
named = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
underRoot (Map FilePath [FilePath] -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath [FilePath]
owners)
      cabalRels :: [FilePath]
cabalRels = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toAscList ([FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ([FilePath]
walked [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
named))
      orphanRels :: [FilePath]
orphanRels = [FilePath
c | FilePath
c <- [FilePath]
cabalRels, Bool -> Bool
not (FilePath -> Map FilePath [FilePath] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member FilePath
c Map FilePath [FilePath]
owners)]
      found :: Set FilePath
found = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
cabalRels
      unreachable :: [(FilePath, [FilePath])]
unreachable = [(FilePath
c, [FilePath]
os) | (FilePath
c, [FilePath]
os) <- Map FilePath [FilePath] -> [(FilePath, [FilePath])]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath [FilePath]
owners, Bool -> Bool
not (FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
c Set FilePath
found)]

  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
warnOrphan [FilePath]
orphanRels
  ((FilePath, [FilePath]) -> IO ())
-> [(FilePath, [FilePath])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath, [FilePath]) -> IO ()
warnUnreachable [(FilePath, [FilePath])]
unreachable

  Map FilePath (Maybe FilePath)
primaries <- [(FilePath, Maybe FilePath)] -> Map FilePath (Maybe FilePath)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, Maybe FilePath)] -> Map FilePath (Maybe FilePath))
-> IO [(FilePath, Maybe FilePath)]
-> IO (Map FilePath (Maybe FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (FilePath, Maybe FilePath))
-> [FilePath] -> IO [(FilePath, Maybe FilePath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map FilePath [FilePath]
-> FilePath -> IO (FilePath, Maybe FilePath)
resolvePrimary Map FilePath [FilePath]
owners) (Map FilePath [FilePath] -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath [FilePath]
owners)
  [Project]
projects <- (FilePath -> IO Project) -> [FilePath] -> IO [Project]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath
-> [FilePath]
-> Map FilePath (Maybe FilePath)
-> FilePath
-> IO Project
buildProject FilePath
root [FilePath]
cabalRels Map FilePath (Maybe FilePath)
primaries) [FilePath]
projectOrder

  Discovery -> IO Discovery
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Discovery
      { discRoot :: FilePath
discRoot = FilePath
root
      , discProjects :: [Project]
discProjects = [Project]
projects
      , discOrphans :: [Orphan]
discOrphans =
          [Orphan{orphCabalFile :: FilePath
orphCabalFile = FilePath
c, orphPackageDir :: FilePath
orphPackageDir = ShowS
relDir FilePath
c} | FilePath
c <- [FilePath]
orphanRels]
      }
 where
  -- Keep owners in project-file order: the map is folded newest-first, so the
  -- accumulated list goes second and new entries are appended after it.
  laterOwnersLast :: [a] -> [a] -> [a]
laterOwnersLast [a]
new [a]
old = [a]
old [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
old) [a]
new

  warnOrphan :: FilePath -> IO ()
warnOrphan FilePath
c =
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"warning: orphan .cabal not referenced by any project: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
c)

  -- A package a project's @packages:@ field names that lies outside the
  -- scanned root, as `packages: ../elsewhere` does. Such a package cannot be
  -- reported: every path in the output is relative to the root, and this one
  -- has none. No cause is asserted beyond the one established -- the path is
  -- not under the root -- because that is all this check knows.
  warnUnreachable :: (FilePath, [FilePath]) -> IO ()
warnUnreachable (FilePath
c, [FilePath]
os) =
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
"warning: "
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
c
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" is referenced by "
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> ShowS -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"a project file" ShowS
describeOwner ([FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe [FilePath]
os)
        FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" but lies outside the scanned root, so it is not reported"

  describeOwner :: ShowS
describeOwner FilePath
o = if FilePath -> Bool
isImplicit FilePath
o then FilePath
"a project file" else FilePath
o

  -- A path the output can express: relative to the root, and not escaping it.
  underRoot :: FilePath -> Bool
underRoot FilePath
p = Bool -> Bool
not (FilePath -> Bool
isAbsolute FilePath
p) Bool -> Bool -> Bool
&& FilePath
".." FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FilePath -> [FilePath]
splitDirectories FilePath
p

  resolvePrimary :: Map FilePath [FilePath]
-> FilePath -> IO (FilePath, Maybe FilePath)
resolvePrimary Map FilePath [FilePath]
owners FilePath
c =
    (FilePath
c,) (Maybe FilePath -> (FilePath, Maybe FilePath))
-> IO (Maybe FilePath) -> IO (FilePath, Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO (Maybe FilePath)
primaryOwner FilePath
c ([FilePath] -> Maybe [FilePath] -> [FilePath]
forall a. a -> Maybe a -> a
fromMaybe [] (FilePath -> Map FilePath [FilePath] -> Maybe [FilePath]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
c Map FilePath [FilePath]
owners))

-- | Sentinel for the synthetic project used when no @cabal.project@ exists.
implicitProject :: FilePath
implicitProject :: FilePath
implicitProject = FilePath
"\0implicit"

isImplicit :: FilePath -> Bool
isImplicit :: FilePath -> Bool
isImplicit = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
implicitProject)

{- | Pick the single project that renders a package.

The default project wins if it reaches the package at all; otherwise the
sorted-first non-default project does, with a warning when more than one claims
it. This has to agree with the @--project-file@ flag chosen in 'suiteCommands',
or a suite would be nested under one project and invoked through another.
-}
primaryOwner :: FilePath -> [FilePath] -> IO (Maybe FilePath)
primaryOwner :: FilePath -> [FilePath] -> IO (Maybe FilePath)
primaryOwner FilePath
cabalRel [FilePath]
os
  | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FilePath -> Bool
isDefault [FilePath]
os = Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isDefault [FilePath]
os))
  | Bool
otherwise = case [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
os of
      [] -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
      (FilePath
chosen : [FilePath]
rest) -> do
        if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
rest
          then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else
            Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"warning: package "
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
cabalRel
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" exclusively owned by multiple non-default project files ("
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
os)
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"); picking '"
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
chosen
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"'"
        Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
chosen)
 where
  isDefault :: FilePath -> Bool
isDefault FilePath
p = FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cabal.project" Bool -> Bool -> Bool
|| FilePath -> Bool
isImplicit FilePath
p

buildProject
  :: FilePath
  -- ^ absolute root
  -> [FilePath]
  -- ^ all .cabal files, relative, in discovery order
  -> Map FilePath (Maybe FilePath)
  -- ^ .cabal -> primary owner
  -> FilePath
  -- ^ this project file (or the implicit sentinel)
  -> IO Project
buildProject :: FilePath
-> [FilePath]
-> Map FilePath (Maybe FilePath)
-> FilePath
-> IO Project
buildProject FilePath
root [FilePath]
cabalRels Map FilePath (Maybe FilePath)
primaries FilePath
projRel = do
  [Package]
pkgs <- (FilePath -> IO Package) -> [FilePath] -> IO [Package]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> Maybe FilePath -> FilePath -> IO Package
buildPackage FilePath
root Maybe FilePath
flag) [FilePath]
mine
  Project -> IO Project
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Project
      { projProjectFile :: Maybe FilePath
projProjectFile = if FilePath -> Bool
isImplicit FilePath
projRel then Maybe FilePath
forall a. Maybe a
Nothing else FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
projRel
      , projPackages :: [Package]
projPackages = [Package]
pkgs
      }
 where
  mine :: [FilePath]
mine = [FilePath
c | FilePath
c <- [FilePath]
cabalRels, FilePath -> Map FilePath (Maybe FilePath) -> Maybe (Maybe FilePath)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
c Map FilePath (Maybe FilePath)
primaries Maybe (Maybe FilePath) -> Maybe (Maybe FilePath) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe FilePath -> Maybe (Maybe FilePath)
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
projRel)]

  -- The flag comes from the same primary owner as the nesting above.
  flag :: Maybe FilePath
flag
    | FilePath -> Bool
isImplicit FilePath
projRel Bool -> Bool -> Bool
|| FilePath
projRel FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cabal.project" = Maybe FilePath
forall a. Maybe a
Nothing
    | Bool
otherwise = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
projRel

buildPackage :: FilePath -> Maybe FilePath -> FilePath -> IO Package
buildPackage :: FilePath -> Maybe FilePath -> FilePath -> IO Package
buildPackage FilePath
root Maybe FilePath
flag FilePath
cabalRel = do
  FilePath
contents <- FilePath -> IO FilePath
readFileLenient (FilePath
root FilePath -> ShowS
</> FilePath
cabalRel)
  let pkgDir :: FilePath
pkgDir = ShowS
relDir FilePath
cabalRel
  [TestSuite]
stanzas <- FilePath -> FilePath -> FilePath -> IO [TestSuite]
parseTestSuites FilePath
root FilePath
pkgDir FilePath
contents
  Package -> IO Package
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Package
      { pkgName :: Text
pkgName = FilePath -> Text
packageNameOf FilePath
contents
      , pkgCabalFile :: FilePath
pkgCabalFile = FilePath
cabalRel
      , pkgPackageDir :: FilePath
pkgPackageDir = FilePath
pkgDir
      , pkgTestSuites :: [TestSuite]
pkgTestSuites = (TestSuite -> TestSuite) -> [TestSuite] -> [TestSuite]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FilePath -> TestSuite -> TestSuite
suiteCommands Maybe FilePath
flag) [TestSuite]
stanzas
      }

-- | Attach the three commands to a parsed stanza.
suiteCommands :: Maybe FilePath -> TestSuite -> TestSuite
suiteCommands :: Maybe FilePath -> TestSuite -> TestSuite
suiteCommands Maybe FilePath
flag TestSuite
ts =
  TestSuite
ts
    { tsRunTestsCommand = base
    , tsStreamTestsCommand = streamingOnly (base <> " --test-options=--streaming-json")
    , tsDiscoverCommand = streamingOnly (base <> " --test-options=--list-tests-json")
    }
 where
  base :: Text
base =
    Text
"cabal test "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestSuite -> Text
tsName TestSuite
ts
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (FilePath -> Text) -> Maybe FilePath -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\FilePath
f -> Text
" --project-file=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
f) Maybe FilePath
flag

  streamingOnly :: a -> Maybe a
streamingOnly a
cmd
    | TestSuite -> EntryPoint
tsEntryPoint TestSuite
ts EntryPoint -> EntryPoint -> Bool
forall a. Eq a => a -> a -> Bool
== EntryPoint
Streaming = a -> Maybe a
forall a. a -> Maybe a
Just a
cmd
    | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- .cabal parsing
-- ---------------------------------------------------------------------------

-- | The package's @name:@ field, or @""@ when it has none.
packageNameOf :: String -> Text
packageNameOf :: FilePath -> Text
packageNameOf FilePath
contents =
  Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
    [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe
      [ Text -> Text
Text.strip (FilePath -> Text
Text.pack (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
5 FilePath
line))
      | FilePath
line <- FilePath -> [FilePath]
lines FilePath
contents
      , (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
5 FilePath
line) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"name:"
      ]

{- | Parse the @test-suite@ stanzas of one @.cabal@ file.

A stanza runs from a @test-suite \<name\>@ line at column 0 until the next
column-0 declaration. @main-is@ is resolved against each of the stanza's
@hs-source-dirs@ in order; the first path that exists on disk wins and its
source is classified. When none exists the suite is reported as @MISSING@,
which keeps a typo'd (or generated-but-absent) entry point visible instead of
silently dropping the suite.
-}
parseTestSuites
  :: FilePath
  -- ^ absolute root
  -> FilePath
  -- ^ package dir, relative to root
  -> String
  -- ^ the @.cabal@ contents
  -> IO [TestSuite]
parseTestSuites :: FilePath -> FilePath -> FilePath -> IO [TestSuite]
parseTestSuites FilePath
root FilePath
pkgDir FilePath
contents =
  ((Text, Maybe FilePath, [FilePath]) -> IO TestSuite)
-> [(Text, Maybe FilePath, [FilePath])] -> IO [TestSuite]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text, Maybe FilePath, [FilePath]) -> IO TestSuite
finish (Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
forall a. Maybe a
Nothing (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
stripCR (FilePath -> [FilePath]
lines FilePath
contents)))
 where
  stripCR :: ShowS
stripCR FilePath
l = if Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
l) Bool -> Bool -> Bool
&& FilePath -> Char
forall a. HasCallStack => [a] -> a
last FilePath
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' then ShowS
forall a. HasCallStack => [a] -> [a]
init FilePath
l else FilePath
l

  -- Gather (name, main-is, hs-source-dirs) triples in file order.
  collect :: Maybe (Text, Maybe String, [String]) -> [String] -> [(Text, Maybe String, [String])]
  collect :: Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
acc [] = Maybe (Text, Maybe FilePath, [FilePath])
-> [(Text, Maybe FilePath, [FilePath])]
forall {a}. Maybe a -> [a]
flush Maybe (Text, Maybe FilePath, [FilePath])
acc
  collect Maybe (Text, Maybe FilePath, [FilePath])
acc (FilePath
l : [FilePath]
ls)
    -- cabal ignores `--` comments and blank lines at any indentation, column 0
    -- included, so neither may be mistaken for the start of the next
    -- declaration. Ending the stanza on one would drop the fields after it,
    -- and losing `main-is` reports a perfectly good suite as MISSING.
    | FilePath -> Bool
isIgnorable FilePath
l = Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
acc [FilePath]
ls
    | FilePath -> Bool
startsDeclaration FilePath
l = case FilePath -> Maybe Text
testSuiteName FilePath
l of
        Just Text
nm -> Maybe (Text, Maybe FilePath, [FilePath])
-> [(Text, Maybe FilePath, [FilePath])]
forall {a}. Maybe a -> [a]
flush Maybe (Text, Maybe FilePath, [FilePath])
acc [(Text, Maybe FilePath, [FilePath])]
-> [(Text, Maybe FilePath, [FilePath])]
-> [(Text, Maybe FilePath, [FilePath])]
forall a. [a] -> [a] -> [a]
++ Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect ((Text, Maybe FilePath, [FilePath])
-> Maybe (Text, Maybe FilePath, [FilePath])
forall a. a -> Maybe a
Just (Text
nm, Maybe FilePath
forall a. Maybe a
Nothing, [FilePath
"."])) [FilePath]
ls
        Maybe Text
Nothing -> Maybe (Text, Maybe FilePath, [FilePath])
-> [(Text, Maybe FilePath, [FilePath])]
forall {a}. Maybe a -> [a]
flush Maybe (Text, Maybe FilePath, [FilePath])
acc [(Text, Maybe FilePath, [FilePath])]
-> [(Text, Maybe FilePath, [FilePath])]
-> [(Text, Maybe FilePath, [FilePath])]
forall a. [a] -> [a] -> [a]
++ Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
forall a. Maybe a
Nothing [FilePath]
ls
    | Bool
otherwise = case Maybe (Text, Maybe FilePath, [FilePath])
acc of
        Maybe (Text, Maybe FilePath, [FilePath])
Nothing -> Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
forall a. Maybe a
Nothing [FilePath]
ls
        Just (Text
nm, Maybe FilePath
mainIs, [FilePath]
dirs) -> case FilePath -> Maybe (FilePath, FilePath)
indentedField FilePath
l of
          Just (FilePath
"main-is", FilePath
v) -> Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect ((Text, Maybe FilePath, [FilePath])
-> Maybe (Text, Maybe FilePath, [FilePath])
forall a. a -> Maybe a
Just (Text
nm, FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
v, [FilePath]
dirs)) [FilePath]
ls
          Just (FilePath
"hs-source-dirs", FilePath
v) -> Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect ((Text, Maybe FilePath, [FilePath])
-> Maybe (Text, Maybe FilePath, [FilePath])
forall a. a -> Maybe a
Just (Text
nm, Maybe FilePath
mainIs, FilePath -> [FilePath]
splitDirsField FilePath
v)) [FilePath]
ls
          Maybe (FilePath, FilePath)
_ -> Maybe (Text, Maybe FilePath, [FilePath])
-> [FilePath] -> [(Text, Maybe FilePath, [FilePath])]
collect Maybe (Text, Maybe FilePath, [FilePath])
acc [FilePath]
ls

  flush :: Maybe a -> [a]
flush = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [])

  isIgnorable :: FilePath -> Bool
isIgnorable FilePath
l = let t :: FilePath
t = ShowS
trim FilePath
l in FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
t Bool -> Bool -> Bool
|| FilePath
"--" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
t

  -- A new declaration starts with a letter at column 0 -- the same rule the
  -- reference awk (/^[a-zA-Z]/) applies.
  startsDeclaration :: FilePath -> Bool
startsDeclaration = \case
    (Char
c : FilePath
_) -> Char -> Bool
isAlpha Char
c
    [] -> Bool
False

  testSuiteName :: FilePath -> Maybe Text
testSuiteName FilePath
l = case FilePath -> [FilePath]
words FilePath
l of
    (FilePath
kw : FilePath
nm : [FilePath]
_) | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
kw FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"test-suite" -> Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
Text.pack FilePath
nm)
    [FilePath]
_ -> Maybe Text
forall a. Maybe a
Nothing

  indentedField :: FilePath -> Maybe (FilePath, FilePath)
indentedField FilePath
l =
    let (FilePath
leading, FilePath
rest) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace FilePath
l
     in if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
leading
          then Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing
          else case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') FilePath
rest of
            (FilePath
nameField, Char
':' : FilePath
v) -> (FilePath, FilePath) -> Maybe (FilePath, FilePath)
forall a. a -> Maybe a
Just ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim FilePath
nameField), ShowS
trim FilePath
v)
            (FilePath, FilePath)
_ -> Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing

  finish :: (Text, Maybe FilePath, [FilePath]) -> IO TestSuite
finish (Text
nm, Maybe FilePath
mainIs, [FilePath]
dirs) = case Maybe FilePath
mainIs of
    Maybe FilePath
Nothing -> TestSuite -> IO TestSuite
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> EntryPoint -> [FilePath] -> TestSuite
mkSuite Text
nm Text
"MISSING" EntryPoint
MissingEntry [FilePath]
dirs)
    Just FilePath
m -> do
      -- Report main-is relative to the package dir, which is the source dir
      -- that matched joined with the stanza's own main-is value.
      Maybe (FilePath, FilePath)
resolved <- [(FilePath, FilePath)] -> IO (Maybe (FilePath, FilePath))
forall a. [(a, FilePath)] -> IO (Maybe (a, FilePath))
firstExisting [(FilePath
d FilePath -> ShowS
</> FilePath
m, FilePath
root FilePath -> ShowS
</> FilePath
pkgDir FilePath -> ShowS
</> FilePath
d FilePath -> ShowS
</> FilePath
m) | FilePath
d <- [FilePath]
dirs, Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
d)]
      case Maybe (FilePath, FilePath)
resolved of
        Maybe (FilePath, FilePath)
Nothing -> TestSuite -> IO TestSuite
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> EntryPoint -> [FilePath] -> TestSuite
mkSuite Text
nm Text
"MISSING" EntryPoint
MissingEntry [FilePath]
dirs)
        Just (FilePath
rel, FilePath
abs') -> do
          EntryPoint
ep <- FilePath -> IO EntryPoint
entryPointOfFile FilePath
abs'
          TestSuite -> IO TestSuite
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> EntryPoint -> [FilePath] -> TestSuite
mkSuite Text
nm (FilePath -> Text
Text.pack FilePath
rel) EntryPoint
ep [FilePath]
dirs)

  -- Commands are filled in later by 'suiteCommands', which is the only place
  -- that knows the owning project file.
  mkSuite :: Text -> Text -> EntryPoint -> [FilePath] -> TestSuite
mkSuite Text
nm Text
mis EntryPoint
ep [FilePath]
dirs =
    TestSuite
      { tsName :: Text
tsName = Text
nm
      , tsMainIs :: Text
tsMainIs = Text
mis
      , tsEntryPoint :: EntryPoint
tsEntryPoint = EntryPoint
ep
      , tsRunTestsCommand :: Text
tsRunTestsCommand = Text
""
      , tsStreamTestsCommand :: Maybe Text
tsStreamTestsCommand = Maybe Text
forall a. Maybe a
Nothing
      , tsDiscoverCommand :: Maybe Text
tsDiscoverCommand = Maybe Text
forall a. Maybe a
Nothing
      , tsHsSourceDirs :: [Text]
tsHsSourceDirs = (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
Text.pack [FilePath]
dirs
      }

-- | @hs-source-dirs@ is whitespace- and/or comma-separated.
splitDirsField :: String -> [String]
splitDirsField :: FilePath -> [FilePath]
splitDirsField FilePath
s = case (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (FilePath -> FilePath -> [FilePath]
splitOnAny FilePath
" \t," FilePath
s) of
  [] -> [FilePath
"."]
  [FilePath]
ds -> [FilePath]
ds

{- | Classify a @main-is@ source file by the tasty runner it calls.

'Streaming' is tested first so the @*WithIngredients@ variants are never
mistaken for plain upstream @defaultMain@.
-}
entryPointOfFile :: FilePath -> IO EntryPoint
entryPointOfFile :: FilePath -> IO EntryPoint
entryPointOfFile FilePath
fp = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fp
  if Bool -> Bool
not Bool
exists
    then EntryPoint -> IO EntryPoint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EntryPoint
MissingEntry
    else FilePath -> EntryPoint
classifySource (FilePath -> EntryPoint) -> IO FilePath -> IO EntryPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFileLenient FilePath
fp

-- | The pure half of 'entryPointOfFile'.
classifySource :: String -> EntryPoint
classifySource :: FilePath -> EntryPoint
classifySource FilePath
src
  | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
src) [FilePath]
streamingMarkers = EntryPoint
Streaming
  | (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
src) [FilePath]
upstreamMarkers = EntryPoint
Upstream
  | Bool
otherwise = EntryPoint
UnknownEntry
 where
  streamingMarkers :: [FilePath]
streamingMarkers =
    [ FilePath
"defaultMainStreamingWithIngredients"
    , FilePath
"defaultMainStreaming"
    , FilePath
"defaultMainTestingInterface"
    , FilePath
"Convex.Tasty.Streaming"
    , FilePath
"Convex.TestingInterface"
    ]
  upstreamMarkers :: [FilePath]
upstreamMarkers =
    [ FilePath
"defaultMainWithIngredients"
    , FilePath
"defaultMain"
    ]

-- ---------------------------------------------------------------------------
-- cabal.project parsing
-- ---------------------------------------------------------------------------

{- | The @cabal.project@ / @cabal.project.*@ files at the top level of @root@,
sorted.

Only the top level is scanned because that is the only place @cabal@ honours
them, and @.freeze@ / @.local@ are excluded: they configure a project rather
than declaring one.
-}
projectFilesIn :: FilePath -> IO [FilePath]
projectFilesIn :: FilePath -> IO [FilePath]
projectFilesIn FilePath
root = do
  [FilePath]
entries <- FilePath -> IO [FilePath]
listDirectory FilePath
root
  [FilePath]
files <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\FilePath
e -> FilePath -> IO Bool
doesFileExist (FilePath
root FilePath -> ShowS
</> FilePath
e)) [FilePath]
entries
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isProjectFile [FilePath]
files))
 where
  isProjectFile :: FilePath -> Bool
isProjectFile FilePath
e =
    (FilePath
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cabal.project" Bool -> Bool -> Bool
|| FilePath
"cabal.project." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
e)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath
".freeze" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
e)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath
".local" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
e)

-- | Which @.cabal@ files (relative to root) this project file claims.
ownersOfProject :: FilePath -> FilePath -> IO (Map FilePath [FilePath])
ownersOfProject :: FilePath -> FilePath -> IO (Map FilePath [FilePath])
ownersOfProject FilePath
root FilePath
projRel = do
  Set FilePath
cabals <- FilePath -> Set FilePath -> FilePath -> IO (Set FilePath)
collectProjectPackages FilePath
root Set FilePath
forall a. Set a
Set.empty (FilePath
root FilePath -> ShowS
</> FilePath
projRel)
  Map FilePath [FilePath] -> IO (Map FilePath [FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(FilePath, [FilePath])] -> Map FilePath [FilePath]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FilePath
c, [FilePath
projRel]) | FilePath
c <- Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
cabals])

{- | Recursively collect the @.cabal@ paths a project file's @packages:@ reach,
following @import:@ with a visited set so a diamond of imports terminates.
-}
collectProjectPackages
  :: FilePath
  -- ^ absolute root, for relativising results
  -> Set FilePath
  -- ^ already-visited project files
  -> FilePath
  -- ^ absolute project file to read
  -> IO (Set FilePath)
collectProjectPackages :: FilePath -> Set FilePath -> FilePath -> IO (Set FilePath)
collectProjectPackages FilePath
root Set FilePath
visited FilePath
pfile
  | FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
pfile Set FilePath
visited = Set FilePath -> IO (Set FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set FilePath
forall a. Set a
Set.empty
  | Bool
otherwise = do
      Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
pfile
      if Bool -> Bool
not Bool
exists
        then Set FilePath -> IO (Set FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set FilePath
forall a. Set a
Set.empty
        else do
          FilePath
contents <- FilePath -> IO FilePath
readFileLenient FilePath
pfile
          Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go
            (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
pfile Set FilePath
visited)
            (ShowS
takeDirectory FilePath
pfile)
            Set FilePath
forall a. Set a
Set.empty
            PkgState
NotInPackages
            (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
stripComment (FilePath -> [FilePath]
lines FilePath
contents))
 where
  go :: Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
_ FilePath
_ Set FilePath
acc PkgState
_ [] = Set FilePath -> IO (Set FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set FilePath
acc
  go Set FilePath
vis FilePath
pdir Set FilePath
acc PkgState
st (FilePath
l : [FilePath]
ls)
    -- A source-repository-package stanza declares dependencies, not local
    -- packages, so its indented body is skipped entirely. A dedented line
    -- ends the stanza and is then processed normally.
    | PkgState
st PkgState -> PkgState -> Bool
forall a. Eq a => a -> a -> Bool
== PkgState
InSourceRepo Bool -> Bool -> Bool
&& FilePath -> Bool
indented FilePath
l = Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir Set FilePath
acc PkgState
InSourceRepo [FilePath]
ls
    | FilePath
"source-repository-package" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
l = Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir Set FilePath
acc PkgState
InSourceRepo [FilePath]
ls
    | Just FilePath
imp <- FilePath -> FilePath -> Maybe FilePath
nonEmptyField FilePath
"import" FilePath
l = do
        let target :: FilePath
target = FilePath
pdir FilePath -> ShowS
</> FilePath
imp
        Set FilePath
inner <- FilePath -> Set FilePath -> FilePath -> IO (Set FilePath)
collectProjectPackages FilePath
root Set FilePath
vis FilePath
target
        -- Thread the visited set forward so sibling imports of a shared file
        -- are not read twice.
        Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
target Set FilePath
vis) FilePath
pdir (Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set FilePath
acc Set FilePath
inner) PkgState
NotInPackages [FilePath]
ls
    | Just FilePath
rest <- FilePath -> FilePath -> Maybe FilePath
fieldValue FilePath
"packages" FilePath
l = do
        Set FilePath
found <- FilePath -> [FilePath] -> IO (Set FilePath)
forall {t :: * -> *}.
Traversable t =>
FilePath -> t FilePath -> IO (Set FilePath)
resolveTokens FilePath
pdir (FilePath -> [FilePath]
tokens FilePath
rest)
        Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir (Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set FilePath
acc Set FilePath
found) PkgState
InPackages [FilePath]
ls
    | Bool -> Bool
not (FilePath -> Bool
indented FilePath
l) = Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir Set FilePath
acc PkgState
NotInPackages [FilePath]
ls
    | PkgState
st PkgState -> PkgState -> Bool
forall a. Eq a => a -> a -> Bool
== PkgState
InPackages = do
        Set FilePath
found <- FilePath -> [FilePath] -> IO (Set FilePath)
forall {t :: * -> *}.
Traversable t =>
FilePath -> t FilePath -> IO (Set FilePath)
resolveTokens FilePath
pdir (FilePath -> [FilePath]
tokens FilePath
l)
        Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir (Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set FilePath
acc Set FilePath
found) PkgState
InPackages [FilePath]
ls
    | Bool
otherwise = Set FilePath
-> FilePath
-> Set FilePath
-> PkgState
-> [FilePath]
-> IO (Set FilePath)
go Set FilePath
vis FilePath
pdir Set FilePath
acc PkgState
st [FilePath]
ls

  resolveTokens :: FilePath -> t FilePath -> IO (Set FilePath)
resolveTokens FilePath
pdir t FilePath
ts =
    [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ([FilePath] -> Set FilePath)
-> (t [FilePath] -> [FilePath]) -> t [FilePath] -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t [FilePath] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (t [FilePath] -> Set FilePath)
-> IO (t [FilePath]) -> IO (Set FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> t FilePath -> IO (t [FilePath])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (FilePath -> FilePath -> FilePath -> IO [FilePath]
resolvePackageEntry FilePath
root FilePath
pdir) t FilePath
ts

  -- cabal accepts comma-separated package lists; drop the separator so such
  -- an entry still resolves.
  tokens :: FilePath -> [FilePath]
tokens = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')) ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words

  indented :: FilePath -> Bool
indented = \case
    (Char
c : FilePath
_) -> Char -> Bool
isSpace Char
c
    [] -> Bool
True

data PkgState = NotInPackages | InPackages | InSourceRepo
  deriving (PkgState -> PkgState -> Bool
(PkgState -> PkgState -> Bool)
-> (PkgState -> PkgState -> Bool) -> Eq PkgState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PkgState -> PkgState -> Bool
== :: PkgState -> PkgState -> Bool
$c/= :: PkgState -> PkgState -> Bool
/= :: PkgState -> PkgState -> Bool
Eq)

{- | Resolve one @packages:@ token to concrete @.cabal@ paths, relative to root.

A token is an explicit @.cabal@ file, a glob, or a bare directory. Whatever a
glob expands to is then classified the same way, which is the part that matters:
@packages: pkgs\/*@ matches *directories*, and each of those contributes the
@.cabal@ files directly inside it, non-recursively, exactly as @cabal@ does.

The shell reference gets this for free because the shell expands the token
before its resolver ever sees it, so that resolver only meets concrete paths.
Expanding the glob ourselves means we have to classify the matches ourselves
too -- an earlier version kept only glob matches that were files, so every
directory-matching glob resolved to nothing and its packages went undiscovered.
-}
resolvePackageEntry :: FilePath -> FilePath -> String -> IO [FilePath]
resolvePackageEntry :: FilePath -> FilePath -> FilePath -> IO [FilePath]
resolvePackageEntry FilePath
root FilePath
pdir FilePath
entry = do
  [FilePath]
candidates <-
    if FilePath -> Bool
isGlob FilePath
entry
      then FilePath -> FilePath -> IO [FilePath]
expandGlob FilePath
pdir FilePath
entry
      else [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
pdir FilePath -> ShowS
</> FilePath
entry]
  [FilePath]
matches <- [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO [FilePath]
classify [FilePath]
candidates
  [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ShowS
dropPrefixPath (FilePath
root FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"/") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalisePath) [FilePath]
matches)
 where
  -- A candidate is either a .cabal file, taken as-is, or a directory, whose
  -- own .cabal files are taken non-recursively. Anything else contributes
  -- nothing, which also covers a token naming a path that does not exist.
  classify :: FilePath -> IO [FilePath]
classify FilePath
p = do
    Bool
isFile <- FilePath -> IO Bool
doesFileExist FilePath
p
    if Bool
isFile
      then [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
p | ShowS
takeExtension FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"]
      else do
        Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
p
        if Bool -> Bool
not Bool
isDir
          then [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          else do
            [FilePath]
entries <- FilePath -> IO [FilePath]
listDirectory FilePath
p
            (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [FilePath
p FilePath -> ShowS
</> FilePath
e | FilePath
e <- [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
entries, ShowS
takeExtension FilePath
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"]

-- ---------------------------------------------------------------------------
-- Filesystem walk
-- ---------------------------------------------------------------------------

{- | Every @.cabal@ file under @root@, relative to it and sorted.

@dist-newstyle@, @tasty-investigate@, @.git@ and @node_modules@ are pruned:
they hold build artefacts and vendored code whose @.cabal@ files are not part
of the repository's own structure. Symlinks are not followed at all -- neither
descended into nor reported as @.cabal@ files -- which is what the reference's
@find@ does and what keeps a link back to an ancestor from looping.
-}
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles FilePath
root = [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
walk FilePath
""
 where
  walk :: FilePath -> IO [FilePath]
walk FilePath
rel = do
    let dir :: FilePath
dir = if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
rel then FilePath
root else FilePath
root FilePath -> ShowS
</> FilePath
rel
    [FilePath]
entries <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
    [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> FilePath -> IO [FilePath]
visit FilePath
rel) ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
entries)

  visit :: FilePath -> FilePath -> IO [FilePath]
visit FilePath
rel FilePath
e
    | FilePath
e FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
prunedDirs = [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    | Bool
otherwise = do
        let childRel :: FilePath
childRel = if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
rel then FilePath
e else FilePath
rel FilePath -> ShowS
</> FilePath
e
            absPath :: FilePath
absPath = FilePath
root FilePath -> ShowS
</> FilePath
childRel
        -- Symlinks are not followed, matching the reference's `find` (which
        -- needs -L to follow, and whose `-type f` does not match a symlinked
        -- .cabal either). doesDirectoryExist resolves links, so without this a
        -- directory link pointing at an ancestor would make the walk descend
        -- into itself until the kernel's symlink limit stopped it.
        Bool
link <- FilePath -> IO Bool
pathIsSymbolicLink FilePath
absPath
        Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
absPath
        if Bool
isDir Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
link
          then FilePath -> IO [FilePath]
walk FilePath
childRel
          else [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
childRel | Bool -> Bool
not Bool
link, ShowS
takeExtension FilePath
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"]

  prunedDirs :: [FilePath]
prunedDirs = [FilePath
"dist-newstyle", FilePath
"tasty-investigate", FilePath
".git", FilePath
"node_modules"]

-- ---------------------------------------------------------------------------
-- Small helpers
-- ---------------------------------------------------------------------------

{- | Read a file without letting a stray non-UTF-8 byte abort discovery.

Vendored @.cabal@ files and generated sources sometimes carry latin-1 bytes.
The classifier only looks for ASCII markers, so transliterating one byte is
harmless, whereas a decoding exception would lose the entire scan.
-}
readFileLenient :: FilePath -> IO String
readFileLenient :: FilePath -> IO FilePath
readFileLenient FilePath
fp = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fp
  if Bool -> Bool
not Bool
exists
    then FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
""
    else FilePath -> IOMode -> (Handle -> IO FilePath) -> IO FilePath
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fp IOMode
ReadMode ((Handle -> IO FilePath) -> IO FilePath)
-> (Handle -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      TextEncoding
enc <- FilePath -> IO TextEncoding
mkTextEncoding FilePath
"UTF-8//TRANSLIT"
      Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
enc
      FilePath
s <- Handle -> IO FilePath
hGetContents Handle
h
      -- Force before the handle closes: hGetContents is lazy.
      Int
_ <- Int -> IO Int
forall a. a -> IO a
evaluate (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s)
      FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
s

-- | Strip a cabal @--@ line comment.
stripComment :: String -> String
stripComment :: ShowS
stripComment = \case
  [] -> []
  (Char
'-' : Char
'-' : FilePath
_) -> []
  (Char
c : FilePath
cs) -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
stripComment FilePath
cs

{- | @field: value@ at any indentation, case-insensitive on the field name.

Returns 'Nothing' when the line is not that field, so callers can pattern-match
their way through a project file one field at a time.
-}
fieldValue :: String -> String -> Maybe String
fieldValue :: FilePath -> FilePath -> Maybe FilePath
fieldValue FilePath
name FilePath
l =
  case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace FilePath
l) of
    (FilePath
n, Char
':' : FilePath
v) | (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (ShowS
trim FilePath
n) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
name -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (ShowS
trim FilePath
v)
    (FilePath, FilePath)
_ -> Maybe FilePath
forall a. Maybe a
Nothing

-- | 'fieldValue', but an empty value does not count as the field being present.
nonEmptyField :: String -> String -> Maybe String
nonEmptyField :: FilePath -> FilePath -> Maybe FilePath
nonEmptyField FilePath
name FilePath
l = case FilePath -> FilePath -> Maybe FilePath
fieldValue FilePath
name FilePath
l of
  Just FilePath
v | Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
v) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
v
  Maybe FilePath
_ -> Maybe FilePath
forall a. Maybe a
Nothing

{- | Collapse @\/.\/@ and duplicate slashes and strip leading @.\/@, so paths
built from a bare @.@ or a trailing-slash directory token compare equal to the
ones the filesystem walk produced.
-}
normalisePath :: FilePath -> FilePath
normalisePath :: ShowS
normalisePath = ShowS
stripLeadingDots ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
collapse
 where
  collapse :: ShowS
collapse (Char
'/' : Char
'/' : FilePath
rest) = ShowS
collapse (Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
rest)
  collapse (Char
'/' : Char
'.' : Char
'/' : FilePath
rest) = ShowS
collapse (Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
rest)
  collapse FilePath
"/." = FilePath
""
  collapse (Char
c : FilePath
cs) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
collapse FilePath
cs
  collapse [] = []

  stripLeadingDots :: ShowS
stripLeadingDots (Char
'.' : Char
'/' : FilePath
rest) = ShowS
stripLeadingDots FilePath
rest
  stripLeadingDots FilePath
p = FilePath
p

-- | Drop @prefix@ from @path@ when present; otherwise leave it alone.
dropPrefixPath :: String -> FilePath -> FilePath
dropPrefixPath :: FilePath -> ShowS
dropPrefixPath FilePath
prefix FilePath
path
  | FilePath
prefix FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
path = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
prefix) FilePath
path
  | Bool
otherwise = FilePath
path

-- | The directory part of a relative path, as @.@ rather than @""@ at the top.
relDir :: FilePath -> FilePath
relDir :: ShowS
relDir FilePath
p = case ShowS
takeDirectory FilePath
p of
  FilePath
"" -> FilePath
"."
  FilePath
d -> FilePath
d

-- | The first pair whose second component exists on disk.
firstExisting :: [(a, FilePath)] -> IO (Maybe (a, FilePath))
firstExisting :: forall a. [(a, FilePath)] -> IO (Maybe (a, FilePath))
firstExisting [] = Maybe (a, FilePath) -> IO (Maybe (a, FilePath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (a, FilePath)
forall a. Maybe a
Nothing
firstExisting (p :: (a, FilePath)
p@(a
_, FilePath
fp) : [(a, FilePath)]
ps) = do
  Bool
ok <- FilePath -> IO Bool
doesFileExist FilePath
fp
  if Bool
ok then Maybe (a, FilePath) -> IO (Maybe (a, FilePath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, FilePath) -> Maybe (a, FilePath)
forall a. a -> Maybe a
Just (a, FilePath)
p) else [(a, FilePath)] -> IO (Maybe (a, FilePath))
forall a. [(a, FilePath)] -> IO (Maybe (a, FilePath))
firstExisting [(a, FilePath)]
ps

trim :: String -> String
trim :: ShowS
trim = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace

splitOnAny :: [Char] -> String -> [String]
splitOnAny :: FilePath -> FilePath -> [FilePath]
splitOnAny FilePath
seps = (Char -> [FilePath] -> [FilePath])
-> [FilePath] -> FilePath -> [FilePath]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> [FilePath] -> [FilePath]
step [[]]
 where
  step :: Char -> [FilePath] -> [FilePath]
step Char
c acc :: [FilePath]
acc@(FilePath
cur : [FilePath]
rest)
    | Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
seps = [] FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
acc
    | Bool
otherwise = (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
cur) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
rest
  step Char
_ [] = [[]]