{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- | Source-location tracking for tests streamed by the Tasty ingredient.

This module provides:

* 'SrcLocRange' — a JSON-friendly source range type matching the shape used
  elsewhere in this repo (file, startLine, startCol, endLine, endCol).
* 'SrcLocOpt' — a Tasty 'IsOption' instance carrying an optional location.
  Tasty propagates options from 'localOption' down into every child leaf
  through 'PlusTestOptions' nodes, so we use it as a side channel between
  the user-facing API boundary and the streaming ingredient.
* 'withSrcLoc' — a 'HasCallStack'-instrumented combinator that captures the
  immediate caller's source location and attaches it to a 'TestTree' via
  'localOption'.
* 'PackageRootOpt' — a Tasty 'IsOption' carrying the optional absolute path
  to the cabal package containing the user's @Main.hs@. Populated by
  'Convex.Tasty.Streaming.defaultMainStreaming' from the top of the
  'HasCallStack' call-stack and consumed by the streaming reporter / list
  ingredient to populate the @packageRoot@ field on @SuiteStarted@.
* 'callerPackageRoot' / 'findPackageRootFromFile' — helpers that walk up
  from a source file to the nearest enclosing @.cabal@ directory.

This is intentionally kept separate from any specific test provider
('Test.Tasty.HUnit', 'Test.Tasty.QuickCheck', etc.) so that user-facing
shims and library-internal wrappers (e.g. @propRunActions@) can share the
same machinery.
-}
module Convex.Tasty.Streaming.SrcLoc (
  SrcLocRange (..),
  SrcLocOpt (..),
  withSrcLoc,
  currentSrcLocRange,
  fromGhcSrcLoc,
  PackageRootOpt (..),
  callerPackageRoot,
  findPackageRootFromFile,
  SrcLocRanges (..),
  groupRanges,
  ungroupRanges,
) where

import Control.Exception (IOException, catch)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
import Data.List (groupBy, isSuffixOf, sort, zip4)
import Data.Tagged (Tagged (..))
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.Generics (Generic)
import GHC.Stack (
  CallStack,
  HasCallStack,
  SrcLoc,
  callStack,
  getCallStack,
  srcLocEndCol,
  srcLocEndLine,
  srcLocFile,
  srcLocPackage,
  srcLocStartCol,
  srcLocStartLine,
  withFrozenCallStack,
 )
import System.Directory (
  canonicalizePath,
  doesDirectoryExist,
  doesFileExist,
  getCurrentDirectory,
  listDirectory,
 )
import System.FilePath (isAbsolute, takeDirectory, (</>))
import Test.Tasty (TestTree, localOption)
import Test.Tasty.Options (IsOption (..))

{- | A source-location range, semantically equivalent to the LSP/editor
@file:startLine:startCol-endLine:endCol@ shape.

The end position is typically one past the end of the function-name token
(e.g. just past @testCase@), not the end of the user's full expression —
'HasCallStack' does not give us expression spans.
-}
data SrcLocRange = SrcLocRange
  { SrcLocRange -> Text
slrFile :: !Text
  , SrcLocRange -> Int
slrStartLine :: !Int
  , SrcLocRange -> Int
slrStartCol :: !Int
  , SrcLocRange -> Int
slrEndLine :: !Int
  , SrcLocRange -> Int
slrEndCol :: !Int
  }
  deriving (SrcLocRange -> SrcLocRange -> Bool
(SrcLocRange -> SrcLocRange -> Bool)
-> (SrcLocRange -> SrcLocRange -> Bool) -> Eq SrcLocRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SrcLocRange -> SrcLocRange -> Bool
== :: SrcLocRange -> SrcLocRange -> Bool
$c/= :: SrcLocRange -> SrcLocRange -> Bool
/= :: SrcLocRange -> SrcLocRange -> Bool
Eq, Eq SrcLocRange
Eq SrcLocRange =>
(SrcLocRange -> SrcLocRange -> Ordering)
-> (SrcLocRange -> SrcLocRange -> Bool)
-> (SrcLocRange -> SrcLocRange -> Bool)
-> (SrcLocRange -> SrcLocRange -> Bool)
-> (SrcLocRange -> SrcLocRange -> Bool)
-> (SrcLocRange -> SrcLocRange -> SrcLocRange)
-> (SrcLocRange -> SrcLocRange -> SrcLocRange)
-> Ord SrcLocRange
SrcLocRange -> SrcLocRange -> Bool
SrcLocRange -> SrcLocRange -> Ordering
SrcLocRange -> SrcLocRange -> SrcLocRange
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 :: SrcLocRange -> SrcLocRange -> Ordering
compare :: SrcLocRange -> SrcLocRange -> Ordering
$c< :: SrcLocRange -> SrcLocRange -> Bool
< :: SrcLocRange -> SrcLocRange -> Bool
$c<= :: SrcLocRange -> SrcLocRange -> Bool
<= :: SrcLocRange -> SrcLocRange -> Bool
$c> :: SrcLocRange -> SrcLocRange -> Bool
> :: SrcLocRange -> SrcLocRange -> Bool
$c>= :: SrcLocRange -> SrcLocRange -> Bool
>= :: SrcLocRange -> SrcLocRange -> Bool
$cmax :: SrcLocRange -> SrcLocRange -> SrcLocRange
max :: SrcLocRange -> SrcLocRange -> SrcLocRange
$cmin :: SrcLocRange -> SrcLocRange -> SrcLocRange
min :: SrcLocRange -> SrcLocRange -> SrcLocRange
Ord, Int -> SrcLocRange -> ShowS
[SrcLocRange] -> ShowS
SrcLocRange -> String
(Int -> SrcLocRange -> ShowS)
-> (SrcLocRange -> String)
-> ([SrcLocRange] -> ShowS)
-> Show SrcLocRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SrcLocRange -> ShowS
showsPrec :: Int -> SrcLocRange -> ShowS
$cshow :: SrcLocRange -> String
show :: SrcLocRange -> String
$cshowList :: [SrcLocRange] -> ShowS
showList :: [SrcLocRange] -> ShowS
Show, (forall x. SrcLocRange -> Rep SrcLocRange x)
-> (forall x. Rep SrcLocRange x -> SrcLocRange)
-> Generic SrcLocRange
forall x. Rep SrcLocRange x -> SrcLocRange
forall x. SrcLocRange -> Rep SrcLocRange x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SrcLocRange -> Rep SrcLocRange x
from :: forall x. SrcLocRange -> Rep SrcLocRange x
$cto :: forall x. Rep SrcLocRange x -> SrcLocRange
to :: forall x. Rep SrcLocRange x -> SrcLocRange
Generic)

instance ToJSON SrcLocRange where
  toJSON :: SrcLocRange -> Value
toJSON SrcLocRange{Int
Text
slrFile :: SrcLocRange -> Text
slrStartLine :: SrcLocRange -> Int
slrStartCol :: SrcLocRange -> Int
slrEndLine :: SrcLocRange -> Int
slrEndCol :: SrcLocRange -> Int
slrFile :: Text
slrStartLine :: Int
slrStartCol :: Int
slrEndLine :: Int
slrEndCol :: Int
..} =
    [Pair] -> Value
object
      [ Key
"file" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
slrFile
      , Key
"startLine" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
slrStartLine
      , Key
"startCol" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
slrStartCol
      , Key
"endLine" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
slrEndLine
      , Key
"endCol" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
slrEndCol
      ]

instance FromJSON SrcLocRange where
  parseJSON :: Value -> Parser SrcLocRange
parseJSON = String
-> (Object -> Parser SrcLocRange) -> Value -> Parser SrcLocRange
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SrcLocRange" ((Object -> Parser SrcLocRange) -> Value -> Parser SrcLocRange)
-> (Object -> Parser SrcLocRange) -> Value -> Parser SrcLocRange
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> Int -> Int -> Int -> Int -> SrcLocRange
SrcLocRange
      (Text -> Int -> Int -> Int -> Int -> SrcLocRange)
-> Parser Text -> Parser (Int -> Int -> Int -> Int -> SrcLocRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"file"
      Parser (Int -> Int -> Int -> Int -> SrcLocRange)
-> Parser Int -> Parser (Int -> Int -> Int -> SrcLocRange)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"startLine"
      Parser (Int -> Int -> Int -> SrcLocRange)
-> Parser Int -> Parser (Int -> Int -> SrcLocRange)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"startCol"
      Parser (Int -> Int -> SrcLocRange)
-> Parser Int -> Parser (Int -> SrcLocRange)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"endLine"
      Parser (Int -> SrcLocRange) -> Parser Int -> Parser SrcLocRange
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"endCol"

{- | Internal Tasty option carrying the source-location of a test definition.

Not user-settable from the command line; it is only ever populated via
'withSrcLoc' (or, transitively, the @Convex.Tasty.HUnit@ /
@Convex.Tasty.QuickCheck@ shims).
-}
newtype SrcLocOpt = SrcLocOpt (Maybe SrcLocRange)
  deriving (SrcLocOpt -> SrcLocOpt -> Bool
(SrcLocOpt -> SrcLocOpt -> Bool)
-> (SrcLocOpt -> SrcLocOpt -> Bool) -> Eq SrcLocOpt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SrcLocOpt -> SrcLocOpt -> Bool
== :: SrcLocOpt -> SrcLocOpt -> Bool
$c/= :: SrcLocOpt -> SrcLocOpt -> Bool
/= :: SrcLocOpt -> SrcLocOpt -> Bool
Eq, Int -> SrcLocOpt -> ShowS
[SrcLocOpt] -> ShowS
SrcLocOpt -> String
(Int -> SrcLocOpt -> ShowS)
-> (SrcLocOpt -> String)
-> ([SrcLocOpt] -> ShowS)
-> Show SrcLocOpt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SrcLocOpt -> ShowS
showsPrec :: Int -> SrcLocOpt -> ShowS
$cshow :: SrcLocOpt -> String
show :: SrcLocOpt -> String
$cshowList :: [SrcLocOpt] -> ShowS
showList :: [SrcLocOpt] -> ShowS
Show)

instance IsOption SrcLocOpt where
  defaultValue :: SrcLocOpt
defaultValue = Maybe SrcLocRange -> SrcLocOpt
SrcLocOpt Maybe SrcLocRange
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe SrcLocOpt
parseValue = Maybe SrcLocOpt -> String -> Maybe SrcLocOpt
forall a b. a -> b -> a
const Maybe SrcLocOpt
forall a. Maybe a
Nothing
  optionName :: Tagged SrcLocOpt String
optionName = String -> Tagged SrcLocOpt String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal-srcloc"
  optionHelp :: Tagged SrcLocOpt String
optionHelp = String -> Tagged SrcLocOpt String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"Internal: source location of the test definition"

{- | Capture the immediate caller's location from the implicit 'CallStack'.

Returns 'Nothing' if the call stack is empty (e.g. when called from a
context without a 'HasCallStack' chain reaching a real call site).
-}
currentSrcLocRange :: (HasCallStack) => Maybe SrcLocRange
currentSrcLocRange :: HasCallStack => Maybe SrcLocRange
currentSrcLocRange = CallStack -> Maybe SrcLocRange
topOfStack CallStack
HasCallStack => CallStack
callStack
 where
  topOfStack :: CallStack -> Maybe SrcLocRange
  topOfStack :: CallStack -> Maybe SrcLocRange
topOfStack CallStack
cs = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
    ((String
_, SrcLoc
loc) : [(String, SrcLoc)]
_) -> SrcLocRange -> Maybe SrcLocRange
forall a. a -> Maybe a
Just (SrcLoc -> SrcLocRange
fromGhcSrcLoc SrcLoc
loc)
    [(String, SrcLoc)]
_ -> Maybe SrcLocRange
forall a. Maybe a
Nothing

-- | Convert a GHC 'SrcLoc' to our JSON-friendly 'SrcLocRange'.
fromGhcSrcLoc :: SrcLoc -> SrcLocRange
fromGhcSrcLoc :: SrcLoc -> SrcLocRange
fromGhcSrcLoc SrcLoc
loc =
  SrcLocRange
    { slrFile :: Text
slrFile = String -> Text
Text.pack (SrcLoc -> String
srcLocFile SrcLoc
loc)
    , slrStartLine :: Int
slrStartLine = SrcLoc -> Int
srcLocStartLine SrcLoc
loc
    , slrStartCol :: Int
slrStartCol = SrcLoc -> Int
srcLocStartCol SrcLoc
loc
    , slrEndLine :: Int
slrEndLine = SrcLoc -> Int
srcLocEndLine SrcLoc
loc
    , slrEndCol :: Int
slrEndCol = SrcLoc -> Int
srcLocEndCol SrcLoc
loc
    }

{- | Annotate a 'TestTree' with the caller's source location.

Use 'withFrozenCallStack' at the call site if you are writing a shim that
delegates to this combinator, so that the captured location reflects the
shim's caller rather than the shim itself.
-}
withSrcLoc :: (HasCallStack) => TestTree -> TestTree
withSrcLoc :: HasCallStack => TestTree -> TestTree
withSrcLoc = (HasCallStack => TestTree -> TestTree) -> TestTree -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (SrcLocOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe SrcLocRange -> SrcLocOpt
SrcLocOpt Maybe SrcLocRange
HasCallStack => Maybe SrcLocRange
currentSrcLocRange))

{- | Internal Tasty option carrying the absolute path of the cabal package
that contains the user's @Main.hs@ test entry point.

Populated by 'Convex.Tasty.Streaming.defaultMainStreaming' from the top of
the 'HasCallStack' call-stack (which points at the user's @Main.hs@) by
walking up the directory tree until a @.cabal@ file is found. Consumed by
the streaming JSON reporter and the @--list-tests-json@ ingredient to
populate the @packageRoot@ field of the @SuiteStarted@ event.

Not user-settable from the command line. 'defaultValue' is
@PackageRootOpt Nothing@; when no @.cabal@ file can be located above the
caller, the field is omitted from JSON output.
-}
newtype PackageRootOpt = PackageRootOpt (Maybe Text)
  deriving (PackageRootOpt -> PackageRootOpt -> Bool
(PackageRootOpt -> PackageRootOpt -> Bool)
-> (PackageRootOpt -> PackageRootOpt -> Bool) -> Eq PackageRootOpt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PackageRootOpt -> PackageRootOpt -> Bool
== :: PackageRootOpt -> PackageRootOpt -> Bool
$c/= :: PackageRootOpt -> PackageRootOpt -> Bool
/= :: PackageRootOpt -> PackageRootOpt -> Bool
Eq, Int -> PackageRootOpt -> ShowS
[PackageRootOpt] -> ShowS
PackageRootOpt -> String
(Int -> PackageRootOpt -> ShowS)
-> (PackageRootOpt -> String)
-> ([PackageRootOpt] -> ShowS)
-> Show PackageRootOpt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackageRootOpt -> ShowS
showsPrec :: Int -> PackageRootOpt -> ShowS
$cshow :: PackageRootOpt -> String
show :: PackageRootOpt -> String
$cshowList :: [PackageRootOpt] -> ShowS
showList :: [PackageRootOpt] -> ShowS
Show)

instance IsOption PackageRootOpt where
  defaultValue :: PackageRootOpt
defaultValue = Maybe Text -> PackageRootOpt
PackageRootOpt Maybe Text
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe PackageRootOpt
parseValue = Maybe PackageRootOpt -> String -> Maybe PackageRootOpt
forall a b. a -> b -> a
const Maybe PackageRootOpt
forall a. Maybe a
Nothing
  optionName :: Tagged PackageRootOpt String
optionName = String -> Tagged PackageRootOpt String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal-package-root"
  optionHelp :: Tagged PackageRootOpt String
optionHelp = String -> Tagged PackageRootOpt String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"Internal: cabal package root captured from the call site of defaultMainStreaming"

{- | Resolve the cabal package containing the given source file.

The input is typically a 'GHC.Stack.srcLocFile' value: an absolute path
when GHC was run from the package directory, but in practice (under
@cabal run@ and @cabal test@) a path /relative to the package directory/
such as @"test/Spec.hs"@. The current working directory of a @cabal run@
process is the workspace root (the directory containing
@cabal.project@), __not__ the package directory.

Resolution strategy:

* If the path is absolute, walk up its parent directories until a
  directory containing any @.cabal@ file is found. Return that directory.
* If the path is relative, recursively scan downward from the current
  working directory (bounded by 'searchDepth') for any directory that
  both contains a @.cabal@ file and contains the relative path on disk
  (i.e. @D \</\> relativePath@ exists). The first match in a
  depth-first traversal wins. This copes with the common monorepo
  layout where packages live under @src/*\/@ relative to the workspace
  root.

The search is bounded to avoid exploring the entire filesystem in
pathological setups. Hidden directories (those starting with @.@),
@dist-newstyle@, and common build/dependency directories are skipped
to keep the cost predictable.

Returns 'Nothing' when no match is found.

'IOException's from filesystem operations are caught and treated as
empty/absent so that permission errors on unrelated subtrees do not
abort the walk.
-}
findPackageRootFromFile :: FilePath -> IO (Maybe FilePath)
findPackageRootFromFile :: String -> IO (Maybe String)
findPackageRootFromFile String
path
  | String -> Bool
isAbsolute String
path = do
      String
absPath <- String -> IO String
canonicalizePath String
path
      String -> IO (Maybe String)
walkUpAbsolute (ShowS
takeDirectory String
absPath)
  | Bool
otherwise = do
      String
cwd <- IO String
getCurrentDirectory
      Int -> String -> String -> IO (Maybe String)
searchDown Int
searchDepth String
cwd String
path
 where
  -- Maximum recursion depth for the downward search. The known layouts in
  -- this repo place package roots at depth <= 3 (e.g. @src/use-cases/@);
  -- we allow a bit more to be tolerant of deeper monorepo shapes.
  searchDepth :: Int
  searchDepth :: Int
searchDepth = Int
5

  -- Walk up from an absolute starting directory until we find a directory
  -- containing a .cabal file.
  walkUpAbsolute :: String -> IO (Maybe String)
walkUpAbsolute String
dir = do
    Bool
hasCabal <- String -> IO Bool
dirHasCabalFile String
dir
    if Bool
hasCabal
      then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
      else
        let parent :: String
parent = ShowS
takeDirectory String
dir
         in if String
parent String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
dir
              then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
              else String -> IO (Maybe String)
walkUpAbsolute String
parent

  -- Depth-bounded depth-first search rooted at 'dir' for a package
  -- directory whose tree contains 'relPath'.
  searchDown :: Int -> FilePath -> FilePath -> IO (Maybe FilePath)
  searchDown :: Int -> String -> String -> IO (Maybe String)
searchDown Int
depth String
dir String
relPath = do
    -- Try 'dir' itself first.
    Maybe String
selfMatch <- String -> String -> IO (Maybe String)
isPackageWithFile String
dir String
relPath
    case Maybe String
selfMatch of
      Just String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
selfMatch
      Maybe String
Nothing
        | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        | Bool
otherwise -> do
            [String]
entries <-
              String -> IO [String]
listDirectory String
dir
                IO [String] -> (IOException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            let visit :: [String]
visit = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
shouldSkip) [String]
entries
                pickFirst :: [String] -> IO (Maybe String)
pickFirst [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
                pickFirst (String
e : [String]
es) = do
                  let sub :: String
sub = String
dir String -> ShowS
</> String
e
                  Bool
isDir <- String -> IO Bool
doesDirectoryExist String
sub
                  if Bool
isDir
                    then do
                      Maybe String
m <- Int -> String -> String -> IO (Maybe String)
searchDown (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
sub String
relPath
                      case Maybe String
m of
                        Just String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
m
                        Maybe String
Nothing -> [String] -> IO (Maybe String)
pickFirst [String]
es
                    else [String] -> IO (Maybe String)
pickFirst [String]
es
            [String] -> IO (Maybe String)
pickFirst [String]
visit

  isPackageWithFile :: String -> String -> IO (Maybe String)
isPackageWithFile String
dir String
relPath = do
    Bool
hasCabal <- String -> IO Bool
dirHasCabalFile String
dir
    if Bool
hasCabal
      then do
        Bool
exists <- String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
relPath)
        Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Bool
exists then String -> Maybe String
forall a. a -> Maybe a
Just String
dir else Maybe String
forall a. Maybe a
Nothing)
      else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

  dirHasCabalFile :: String -> IO Bool
dirHasCabalFile String
dir = do
    [String]
entries <-
      String -> IO [String]
listDirectory String
dir
        IO [String] -> (IOException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
".cabal" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) [String]
entries)

  -- Skip hidden directories and well-known build/dependency roots so the
  -- search does not descend into @dist-newstyle@, @node_modules@, etc.
  shouldSkip :: String -> Bool
shouldSkip (Char
'.' : String
_) = Bool
True
  shouldSkip String
"dist-newstyle" = Bool
True
  shouldSkip String
"dist" = Bool
True
  shouldSkip String
"node_modules" = Bool
True
  shouldSkip String
_ = Bool
False

{- | Resolve the caller's package root from a 'HasCallStack' constraint.

Returns the absolute path of the directory containing the package's
@.cabal@ file, or 'Nothing' when no match can be located.

The strategy combines two signals from the top of the call stack:

* 'srcLocPackage' — the GHC-internal package identifier of the calling
  module, e.g.
  @"convex-testing-interface-0.1.0.0-inplace-convex-testing-interface-test"@.
  The first @"-<digit>"@ token of that string marks the start of the
  package version; everything before it is the package name.
* 'srcLocFile' — the GHC-recorded source file path, typically
  package-relative (e.g. @"test/Spec.hs"@).

If a package name can be extracted, we search downward from the current
working directory for a directory containing both a matching
@\<name\>.cabal@ file /and/ the relative source file. If the package
name is unavailable or no match is found, we fall back to the
file-based search in 'findPackageRootFromFile'.

Intended to be invoked at the very top of a test entry point (e.g. from
'Convex.Tasty.Streaming.defaultMainStreaming') so that the captured
location corresponds to the user's @Main.hs@.
-}
callerPackageRoot :: (HasCallStack) => IO (Maybe FilePath)
callerPackageRoot :: HasCallStack => IO (Maybe String)
callerPackageRoot = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
  ((String
_, SrcLoc
loc) : [(String, SrcLoc)]
_) -> do
    let pkgName :: Maybe String
pkgName = String -> Maybe String
extractPackageName (SrcLoc -> String
srcLocPackage SrcLoc
loc)
        file :: String
file = SrcLoc -> String
srcLocFile SrcLoc
loc
    case Maybe String
pkgName of
      Just String
name -> do
        String
cwd <- IO String
getCurrentDirectory
        Maybe String
mFound <- String -> String -> String -> IO (Maybe String)
findPackageByName String
cwd String
name String
file
        case Maybe String
mFound of
          Just String
root -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
root)
          Maybe String
Nothing -> String -> IO (Maybe String)
findPackageRootFromFile String
file
      Maybe String
Nothing -> String -> IO (Maybe String)
findPackageRootFromFile String
file
  [(String, SrcLoc)]
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

{- | Extract a cabal package name from a GHC package identifier string.

GHC encodes the package id as @\<name\>-\<version\>[-\<extra\>]@. The
version always starts with a digit, so we take everything before the
first @"-<digit>"@ separator. Returns 'Nothing' if no such separator is
found.

>>> extractPackageName "convex-testing-interface-0.1.0.0-inplace-..."
Just "convex-testing-interface"
>>> extractPackageName "base-4.18.2.1"
Just "base"
>>> extractPackageName ""
Nothing
-}
extractPackageName :: String -> Maybe String
extractPackageName :: String -> Maybe String
extractPackageName = String -> String -> Maybe String
go []
 where
  go :: String -> String -> Maybe String
go String
acc (Char
'-' : Char
c : String
rest)
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = String -> Maybe String
forall a. a -> Maybe a
Just (ShowS
forall a. [a] -> [a]
reverse String
acc)
    | Bool
otherwise = String -> String -> Maybe String
go (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
rest
  go String
acc (Char
c : String
rest) = String -> String -> Maybe String
go (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
rest
  go String
_ [] = Maybe String
forall a. Maybe a
Nothing

{- | Recursive depth-bounded search rooted at 'startDir' for a directory
containing both a @\<pkgName\>.cabal@ file and the relative source
'relFile'. Returns the directory on success.
-}
findPackageByName :: FilePath -> String -> FilePath -> IO (Maybe FilePath)
findPackageByName :: String -> String -> String -> IO (Maybe String)
findPackageByName String
startDir String
pkgName String
relFile = Int -> String -> IO (Maybe String)
forall {a}. (Ord a, Num a) => a -> String -> IO (Maybe String)
go Int
searchDepth String
startDir
 where
  searchDepth :: Int
  searchDepth :: Int
searchDepth = Int
6
  cabalBaseName :: String
cabalBaseName = String
pkgName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".cabal"

  go :: a -> String -> IO (Maybe String)
go a
depth String
dir = do
    -- Check this directory first.
    Bool
hasCabal <- String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
cabalBaseName)
    let relAbsolute :: Bool
relAbsolute = String -> Bool
isAbsolute String
relFile
    Maybe String
selfMatch <-
      if Bool
hasCabal
        then
          if Bool
relAbsolute
            then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
dir)
            else do
              Bool
exists <- String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
relFile)
              Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Bool
exists then String -> Maybe String
forall a. a -> Maybe a
Just String
dir else Maybe String
forall a. Maybe a
Nothing)
        else Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    case Maybe String
selfMatch of
      Just String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
selfMatch
      Maybe String
Nothing
        | a
depth a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        | Bool
otherwise -> do
            [String]
entries <-
              String -> IO [String]
listDirectory String
dir
                IO [String] -> (IOException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            let visit :: [String]
visit = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
shouldSkip) [String]
entries
                pickFirst :: [String] -> IO (Maybe String)
pickFirst [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
                pickFirst (String
e : [String]
es) = do
                  let sub :: String
sub = String
dir String -> ShowS
</> String
e
                  Bool
isDir <- String -> IO Bool
doesDirectoryExist String
sub
                  if Bool
isDir
                    then do
                      Maybe String
m <- a -> String -> IO (Maybe String)
go (a
depth a -> a -> a
forall a. Num a => a -> a -> a
- a
1) String
sub
                      case Maybe String
m of
                        Just String
_ -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
m
                        Maybe String
Nothing -> [String] -> IO (Maybe String)
pickFirst [String]
es
                    else [String] -> IO (Maybe String)
pickFirst [String]
es
            [String] -> IO (Maybe String)
pickFirst [String]
visit

  shouldSkip :: String -> Bool
shouldSkip (Char
'.' : String
_) = Bool
True
  shouldSkip String
"dist-newstyle" = Bool
True
  shouldSkip String
"dist" = Bool
True
  shouldSkip String
"node_modules" = Bool
True
  shouldSkip String
_ = Bool
False

-- | Many ranges in one file, for more efficient JSON serialization
data SrcLocRanges = SrcLocRanges
  { SrcLocRanges -> Text
slrsFile :: !Text
  , SrcLocRanges -> [Int]
slrsStartLines :: [Int]
  , SrcLocRanges -> [Int]
slrsStartCols :: [Int]
  , SrcLocRanges -> [Int]
slrsEndLines :: [Int]
  , SrcLocRanges -> [Int]
slrsEndCols :: [Int]
  }
  deriving (SrcLocRanges -> SrcLocRanges -> Bool
(SrcLocRanges -> SrcLocRanges -> Bool)
-> (SrcLocRanges -> SrcLocRanges -> Bool) -> Eq SrcLocRanges
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SrcLocRanges -> SrcLocRanges -> Bool
== :: SrcLocRanges -> SrcLocRanges -> Bool
$c/= :: SrcLocRanges -> SrcLocRanges -> Bool
/= :: SrcLocRanges -> SrcLocRanges -> Bool
Eq, Int -> SrcLocRanges -> ShowS
[SrcLocRanges] -> ShowS
SrcLocRanges -> String
(Int -> SrcLocRanges -> ShowS)
-> (SrcLocRanges -> String)
-> ([SrcLocRanges] -> ShowS)
-> Show SrcLocRanges
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SrcLocRanges -> ShowS
showsPrec :: Int -> SrcLocRanges -> ShowS
$cshow :: SrcLocRanges -> String
show :: SrcLocRanges -> String
$cshowList :: [SrcLocRanges] -> ShowS
showList :: [SrcLocRanges] -> ShowS
Show, (forall x. SrcLocRanges -> Rep SrcLocRanges x)
-> (forall x. Rep SrcLocRanges x -> SrcLocRanges)
-> Generic SrcLocRanges
forall x. Rep SrcLocRanges x -> SrcLocRanges
forall x. SrcLocRanges -> Rep SrcLocRanges x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SrcLocRanges -> Rep SrcLocRanges x
from :: forall x. SrcLocRanges -> Rep SrcLocRanges x
$cto :: forall x. Rep SrcLocRanges x -> SrcLocRanges
to :: forall x. Rep SrcLocRanges x -> SrcLocRanges
Generic)

instance ToJSON SrcLocRanges where
  toJSON :: SrcLocRanges -> Value
toJSON SrcLocRanges{[Int]
Text
slrsFile :: SrcLocRanges -> Text
slrsStartLines :: SrcLocRanges -> [Int]
slrsStartCols :: SrcLocRanges -> [Int]
slrsEndLines :: SrcLocRanges -> [Int]
slrsEndCols :: SrcLocRanges -> [Int]
slrsFile :: Text
slrsStartLines :: [Int]
slrsStartCols :: [Int]
slrsEndLines :: [Int]
slrsEndCols :: [Int]
..} =
    [Pair] -> Value
object
      [ Key
"file" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
slrsFile
      , Key
"startLines" Key -> [Int] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
slrsStartLines
      , Key
"startCols" Key -> [Int] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
slrsStartCols
      , Key
"endLines" Key -> [Int] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
slrsEndLines
      , Key
"endCols" Key -> [Int] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int]
slrsEndCols
      ]

instance FromJSON SrcLocRanges where
  parseJSON :: Value -> Parser SrcLocRanges
parseJSON = String
-> (Object -> Parser SrcLocRanges) -> Value -> Parser SrcLocRanges
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"SrcLocRanges" ((Object -> Parser SrcLocRanges) -> Value -> Parser SrcLocRanges)
-> (Object -> Parser SrcLocRanges) -> Value -> Parser SrcLocRanges
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> [Int] -> [Int] -> [Int] -> [Int] -> SrcLocRanges
SrcLocRanges
      (Text -> [Int] -> [Int] -> [Int] -> [Int] -> SrcLocRanges)
-> Parser Text
-> Parser ([Int] -> [Int] -> [Int] -> [Int] -> SrcLocRanges)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"file"
      Parser ([Int] -> [Int] -> [Int] -> [Int] -> SrcLocRanges)
-> Parser [Int] -> Parser ([Int] -> [Int] -> [Int] -> SrcLocRanges)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Int]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"startLines"
      Parser ([Int] -> [Int] -> [Int] -> SrcLocRanges)
-> Parser [Int] -> Parser ([Int] -> [Int] -> SrcLocRanges)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Int]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"startCols"
      Parser ([Int] -> [Int] -> SrcLocRanges)
-> Parser [Int] -> Parser ([Int] -> SrcLocRanges)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Int]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"endLines"
      Parser ([Int] -> SrcLocRanges)
-> Parser [Int] -> Parser SrcLocRanges
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Int]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"endCols"

groupRanges :: [SrcLocRange] -> [SrcLocRanges]
groupRanges :: [SrcLocRange] -> [SrcLocRanges]
groupRanges = ([SrcLocRange] -> SrcLocRanges)
-> [[SrcLocRange]] -> [SrcLocRanges]
forall a b. (a -> b) -> [a] -> [b]
map [SrcLocRange] -> SrcLocRanges
toRanges ([[SrcLocRange]] -> [SrcLocRanges])
-> ([SrcLocRange] -> [[SrcLocRange]])
-> [SrcLocRange]
-> [SrcLocRanges]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcLocRange -> SrcLocRange -> Bool)
-> [SrcLocRange] -> [[SrcLocRange]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\SrcLocRange
a SrcLocRange
b -> SrcLocRange -> Text
slrFile SrcLocRange
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SrcLocRange -> Text
slrFile SrcLocRange
b) ([SrcLocRange] -> [[SrcLocRange]])
-> ([SrcLocRange] -> [SrcLocRange])
-> [SrcLocRange]
-> [[SrcLocRange]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SrcLocRange] -> [SrcLocRange]
forall a. Ord a => [a] -> [a]
sort
 where
  toRanges :: [SrcLocRange] -> SrcLocRanges
  toRanges :: [SrcLocRange] -> SrcLocRanges
toRanges rs :: [SrcLocRange]
rs@(SrcLocRange
r : [SrcLocRange]
_) =
    SrcLocRanges
      { slrsFile :: Text
slrsFile = SrcLocRange -> Text
slrFile SrcLocRange
r
      , slrsStartLines :: [Int]
slrsStartLines = (SrcLocRange -> Int) -> [SrcLocRange] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map SrcLocRange -> Int
slrStartLine [SrcLocRange]
rs
      , slrsStartCols :: [Int]
slrsStartCols = (SrcLocRange -> Int) -> [SrcLocRange] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map SrcLocRange -> Int
slrStartCol [SrcLocRange]
rs
      , slrsEndLines :: [Int]
slrsEndLines = (SrcLocRange -> Int) -> [SrcLocRange] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map SrcLocRange -> Int
slrEndLine [SrcLocRange]
rs
      , slrsEndCols :: [Int]
slrsEndCols = (SrcLocRange -> Int) -> [SrcLocRange] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map SrcLocRange -> Int
slrEndCol [SrcLocRange]
rs
      }
  toRanges [] = String -> SrcLocRanges
forall a. HasCallStack => String -> a
error String
"groupRanges: invalid groupBy result"

ungroupRanges :: [SrcLocRanges] -> [SrcLocRange]
ungroupRanges :: [SrcLocRanges] -> [SrcLocRange]
ungroupRanges = (SrcLocRanges -> [SrcLocRange]) -> [SrcLocRanges] -> [SrcLocRange]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SrcLocRanges -> [SrcLocRange]
go
 where
  allEqual :: [b] -> Bool
allEqual [b]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((b -> b -> Bool) -> [b] -> [b] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) [b]
xs ([b] -> [b]
forall a. HasCallStack => [a] -> [a]
tail [b]
xs))
  go :: SrcLocRanges -> [SrcLocRange]
go SrcLocRanges{[Int]
Text
slrsFile :: SrcLocRanges -> Text
slrsStartLines :: SrcLocRanges -> [Int]
slrsStartCols :: SrcLocRanges -> [Int]
slrsEndLines :: SrcLocRanges -> [Int]
slrsEndCols :: SrcLocRanges -> [Int]
slrsFile :: Text
slrsStartLines :: [Int]
slrsStartCols :: [Int]
slrsEndLines :: [Int]
slrsEndCols :: [Int]
..} =
    if [Int] -> Bool
forall {b}. Eq b => [b] -> Bool
allEqual (([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]
slrsStartLines, [Int]
slrsStartCols, [Int]
slrsEndLines, [Int]
slrsEndCols])
      then
        [ Text -> Int -> Int -> Int -> Int -> SrcLocRange
SrcLocRange Text
slrsFile Int
sl Int
sc Int
el Int
ec
        | (Int
sl, Int
sc, Int
el, Int
ec) <- [Int] -> [Int] -> [Int] -> [Int] -> [(Int, Int, Int, Int)]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Int]
slrsStartLines [Int]
slrsStartCols [Int]
slrsEndLines [Int]
slrsEndCols
        ]
      else String -> [SrcLocRange]
forall a. HasCallStack => String -> a
error String
"ungroupRanges: expected all 4 lists to have the same length"