{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Skeletest.Internal.TestTargets (
  TestTargets,
  TestTarget (..),
  TestAttrs (..),
  matchesTest,
  parseTestTargets,
) where

import Control.Monad.Combinators.Expr qualified as Parser
import Data.Bifunctor (first)
import Data.Char (isAlphaNum)
import Data.Foldable1 qualified as Foldable1
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Void (Void)
import Text.Megaparsec (Parsec)
import Text.Megaparsec qualified as Parser
import Text.Megaparsec.Char qualified as Parser
import Text.Megaparsec.Char.Lexer qualified as Parser.L

type TestTargets = Maybe TestTarget

data TestTarget
  = -- | Useful for selecting all tests, whether manual or not.
    TestTargetEverything
  | TestTargetFile FilePath
  | TestTargetName Text
  | TestTargetMarker Text
  | TestTargetNot TestTarget
  | TestTargetAnd TestTarget TestTarget
  | TestTargetOr TestTarget TestTarget
  deriving (TestTarget -> TestTarget -> Bool
(TestTarget -> TestTarget -> Bool)
-> (TestTarget -> TestTarget -> Bool) -> Eq TestTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestTarget -> TestTarget -> Bool
== :: TestTarget -> TestTarget -> Bool
$c/= :: TestTarget -> TestTarget -> Bool
/= :: TestTarget -> TestTarget -> Bool
Eq)

data TestAttrs = TestAttrs
  { TestAttrs -> FilePath
testPath :: FilePath
  , TestAttrs -> [Text]
testIdentifier :: [Text]
  , TestAttrs -> [Text]
testMarkers :: [Text]
  }

matchesTest :: TestTarget -> TestAttrs -> Bool
matchesTest :: TestTarget -> TestAttrs -> Bool
matchesTest TestTarget
selection TestAttrs{FilePath
[Text]
testPath :: TestAttrs -> FilePath
testIdentifier :: TestAttrs -> [Text]
testMarkers :: TestAttrs -> [Text]
testPath :: FilePath
testIdentifier :: [Text]
testMarkers :: [Text]
..} = TestTarget -> Bool
go TestTarget
selection
  where
    go :: TestTarget -> Bool
go = \case
      TestTarget
TestTargetEverything -> Bool
True
      TestTargetFile FilePath
path -> FilePath
testPath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
path
      TestTargetName Text
s -> Text
s Text -> Text -> Bool
`Text.isInfixOf` [Text] -> Text
Text.unwords [Text]
testIdentifier
      TestTargetMarker Text
marker -> Text
marker Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
testMarkers
      TestTargetNot TestTarget
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestTarget -> Bool
go TestTarget
e
      TestTargetAnd TestTarget
l TestTarget
r -> TestTarget -> Bool
go TestTarget
l Bool -> Bool -> Bool
&& TestTarget -> Bool
go TestTarget
r
      TestTargetOr TestTarget
l TestTarget
r -> TestTarget -> Bool
go TestTarget
l Bool -> Bool -> Bool
|| TestTarget -> Bool
go TestTarget
r

{----- Parsing -----}

parseTestTargets :: [Text] -> Either Text TestTargets
parseTestTargets :: [Text] -> Either Text TestTargets
parseTestTargets [Text]
args =
  case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Text]
args of
    Maybe (NonEmpty Text)
Nothing -> TestTargets -> Either Text TestTargets
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTargets
forall a. Maybe a
Nothing
    Just NonEmpty Text
args' -> TestTarget -> TestTargets
forall a. a -> Maybe a
Just (TestTarget -> TestTargets)
-> (NonEmpty TestTarget -> TestTarget)
-> NonEmpty TestTarget
-> TestTargets
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTarget -> TestTarget -> TestTarget)
-> NonEmpty TestTarget -> TestTarget
forall (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
Foldable1.foldr1 TestTarget -> TestTarget -> TestTarget
TestTargetOr (NonEmpty TestTarget -> TestTargets)
-> Either Text (NonEmpty TestTarget) -> Either Text TestTargets
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either Text TestTarget)
-> NonEmpty Text -> Either Text (NonEmpty TestTarget)
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) -> NonEmpty a -> m (NonEmpty b)
mapM Text -> Either Text TestTarget
parseTestTarget NonEmpty Text
args'
  where
    parseTestTarget :: Text -> Either Text TestTarget
parseTestTarget = (ParseErrorBundle -> Text)
-> Either ParseErrorBundle TestTarget -> Either Text TestTarget
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle -> Text
showTestTargetParseError (Either ParseErrorBundle TestTarget -> Either Text TestTarget)
-> (Text -> Either ParseErrorBundle TestTarget)
-> Text
-> Either Text TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text TestTarget
-> FilePath -> Text -> Either ParseErrorBundle TestTarget
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
Parser.parse (Parsec Void Text TestTarget
testTargetParser Parsec Void Text TestTarget
-> ParsecT Void Text Identity () -> Parsec Void Text TestTarget
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Parser.eof) FilePath
""

type Parser = Parsec Void Text
type ParseErrorBundle = Parser.ParseErrorBundle Text Void

testTargetParser :: Parser TestTarget
testTargetParser :: Parsec Void Text TestTarget
testTargetParser =
  Parsec Void Text TestTarget
-> [[Operator (ParsecT Void Text Identity) TestTarget]]
-> Parsec Void Text TestTarget
forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
Parser.makeExprParser
    ( [Parsec Void Text TestTarget] -> Parsec Void Text TestTarget
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
Parser.choice
        [ Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall {a}.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
parens Parsec Void Text TestTarget
testTargetParser
        , Parsec Void Text TestTarget
everythingParser
        , Parsec Void Text TestTarget
nameParser
        , Parsec Void Text TestTarget
markerParser
        , do
            selectFile <- Parsec Void Text TestTarget
fileParser
            -- syntax sugar: FooSpec.hs[abc] == (FooSpec.hs and [abc])
            withName <- maybe id (flip TestTargetAnd) <$> Parser.optional nameParser
            pure $ withName selectFile
        ]
    )
    [ [Tokens Text
-> (TestTarget -> TestTarget)
-> Operator (ParsecT Void Text Identity) TestTarget
forall {a}.
Tokens Text -> (a -> a) -> Operator (ParsecT Void Text Identity) a
prefix Tokens Text
"not" TestTarget -> TestTarget
TestTargetNot]
    , [Tokens Text
-> (TestTarget -> TestTarget -> TestTarget)
-> Operator (ParsecT Void Text Identity) TestTarget
forall {a}.
Tokens Text
-> (a -> a -> a) -> Operator (ParsecT Void Text Identity) a
binary Tokens Text
"and" TestTarget -> TestTarget -> TestTarget
TestTargetAnd, Tokens Text
-> (TestTarget -> TestTarget -> TestTarget)
-> Operator (ParsecT Void Text Identity) TestTarget
forall {a}.
Tokens Text
-> (a -> a -> a) -> Operator (ParsecT Void Text Identity) a
binary Tokens Text
"or" TestTarget -> TestTarget -> TestTarget
TestTargetOr]
    ]
  where
    prefix :: Tokens Text -> (a -> a) -> Operator (ParsecT Void Text Identity) a
prefix Tokens Text
name a -> a
f = ParsecT Void Text Identity (a -> a)
-> Operator (ParsecT Void Text Identity) a
forall (m :: * -> *) a. m (a -> a) -> Operator m a
Parser.Prefix (a -> a
f (a -> a)
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (a -> a)
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
name)
    binary :: Tokens Text
-> (a -> a -> a) -> Operator (ParsecT Void Text Identity) a
binary Tokens Text
name a -> a -> a
f = ParsecT Void Text Identity (a -> a -> a)
-> Operator (ParsecT Void Text Identity) a
forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
Parser.InfixL (a -> a -> a
f (a -> a -> a)
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (a -> a -> a)
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
name)

    symbol :: Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol = ParsecT Void Text Identity ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
Parser.L.symbol ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Parser.space
    parens :: ParsecT Void Text Identity a -> ParsecT Void Text Identity a
parens = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
Parser.between (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
"(") (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
")")

    everythingParser :: Parsec Void Text TestTarget
everythingParser = TestTarget
TestTargetEverything TestTarget
-> ParsecT Void Text Identity (Tokens Text)
-> Parsec Void Text TestTarget
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
"*"

    nameParser :: Parsec Void Text TestTarget
nameParser =
      FilePath
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a.
FilePath
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
FilePath -> m a -> m a
Parser.label FilePath
"test name" (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a b. (a -> b) -> a -> b
$
        (Text -> TestTarget)
-> ParsecT Void Text Identity Text -> Parsec Void Text TestTarget
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> TestTarget
TestTargetName (ParsecT Void Text Identity Text -> Parsec Void Text TestTarget)
-> (ParsecT Void Text Identity Text
    -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> Parsec Void Text TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
Parser.between (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
"[") (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
"]") (ParsecT Void Text Identity Text -> Parsec Void Text TestTarget)
-> ParsecT Void Text Identity Text -> Parsec Void Text TestTarget
forall a b. (a -> b) -> a -> b
$
          Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
Parser.takeWhile1P Maybe FilePath
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
']')

    markerParser :: Parsec Void Text TestTarget
markerParser =
      FilePath
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a.
FilePath
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
FilePath -> m a -> m a
Parser.label FilePath
"marker" (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> Parsec Void Text TestTarget
-> Parsec Void Text TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall {s} {f :: * -> *} {e} {a}.
(Token s ~ Char, MonadParsec e s f) =>
f a -> f a
ignoreSpacesAfter (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a b. (a -> b) -> a -> b
$ do
        _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
symbol Tokens Text
"@"
        fmap TestTargetMarker . Parser.takeWhile1P Nothing $
          (||) <$> isAlphaNum <*> (`elem` ("-_." :: [Char]))

    fileParser :: Parsec Void Text TestTarget
fileParser =
      FilePath
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a.
FilePath
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
FilePath -> m a -> m a
Parser.label FilePath
"test file" (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> Parsec Void Text TestTarget
-> Parsec Void Text TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall {s} {f :: * -> *} {e} {a}.
(Token s ~ Char, MonadParsec e s f) =>
f a -> f a
ignoreSpacesAfter (Parsec Void Text TestTarget -> Parsec Void Text TestTarget)
-> Parsec Void Text TestTarget -> Parsec Void Text TestTarget
forall a b. (a -> b) -> a -> b
$
        (Text -> TestTarget)
-> ParsecT Void Text Identity Text -> Parsec Void Text TestTarget
forall a b.
(a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> TestTarget
TestTargetFile (FilePath -> TestTarget)
-> (Text -> FilePath) -> Text -> TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack) (ParsecT Void Text Identity Text -> Parsec Void Text TestTarget)
-> ((Token Text -> Bool) -> ParsecT Void Text Identity Text)
-> (Token Text -> Bool)
-> Parsec Void Text TestTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
Parser.takeWhile1P Maybe FilePath
forall a. Maybe a
Nothing ((Token Text -> Bool) -> Parsec Void Text TestTarget)
-> (Token Text -> Bool) -> Parsec Void Text TestTarget
forall a b. (a -> b) -> a -> b
$
          Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (Token Text -> Bool) -> Token Text -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
Token Text -> Bool
isAlphaNum (Token Text -> Bool -> Bool)
-> (Token Text -> Bool) -> Token Text -> Bool
forall a b.
(Token Text -> a -> b) -> (Token Text -> a) -> Token Text -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"-_./" :: [Char]))

    ignoreSpacesAfter :: f a -> f a
ignoreSpacesAfter f a
m = f a
m f a -> f () -> f a
forall a b. f a -> f b -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* f ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
Parser.space

showTestTargetParseError :: ParseErrorBundle -> Text
showTestTargetParseError :: ParseErrorBundle -> Text
showTestTargetParseError ParseErrorBundle
bundle =
  let
    line :: Text
line = PosState Text -> Text
forall s. PosState s -> s
Parser.pstateInput (PosState Text -> Text) -> PosState Text -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
Parser.bundlePosState ParseErrorBundle
bundle
    err :: ParseError Text Void
err = NonEmpty (ParseError Text Void) -> ParseError Text Void
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ParseError Text Void) -> ParseError Text Void)
-> NonEmpty (ParseError Text Void) -> ParseError Text Void
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
Parser.bundleErrors ParseErrorBundle
bundle
    pointerLen :: Int
pointerLen =
      case ParseError Text Void
err of
        Parser.TrivialError Int
_ (Just (Parser.Tokens NonEmpty (Token Text)
s)) Set (ErrorItem (Token Text))
_ -> NonEmpty Char -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Char
NonEmpty (Token Text)
s
        ParseError Text Void
_ -> Int
1
   in
    [Text] -> Text
Text.concat
      [ Text
"Could not parse test target: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (ParseError Text Void -> FilePath
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> FilePath
Parser.parseErrorTextPretty ParseError Text Void
err)
      , Text
" |\n"
      , Text
" | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      , Text
" | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (ParseError Text Void -> Int
forall s e. ParseError s e -> Int
Parser.errorOffset ParseError Text Void
err) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
pointerLen Text
"^"
      ]