TestTargets.hs

{-# 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 (Eq)

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

matchesTest :: TestTarget -> TestAttrs -> Bool
matchesTest selection TestAttrs{..} = go selection
 where
  go = \case
    TestTargetEverything -> True
    TestTargetFile path -> testPath == path
    TestTargetName s -> s `Text.isInfixOf` Text.unwords testIdentifier
    TestTargetMarker marker -> marker `elem` testMarkers
    TestTargetNot e -> not $ go e
    TestTargetAnd l r -> go l && go r
    TestTargetOr l r -> go l || go r

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

parseTestTargets :: [Text] -> Either Text TestTargets
parseTestTargets args =
  case NonEmpty.nonEmpty args of
    Nothing -> pure Nothing
    Just args' -> Just . Foldable1.foldr1 TestTargetOr <$> mapM parseTestTarget args'
 where
  parseTestTarget = first showTestTargetParseError . Parser.parse (testTargetParser <* Parser.eof) ""

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

testTargetParser :: Parser TestTarget
testTargetParser =
  Parser.makeExprParser
    ( Parser.choice
        [ parens testTargetParser
        , everythingParser
        , nameParser
        , markerParser
        , do
            selectFile <- fileParser
            -- syntax sugar: FooSpec.hs[abc] == (FooSpec.hs and [abc])
            withName <- maybe id (flip TestTargetAnd) <$> Parser.optional nameParser
            pure $ withName selectFile
        ]
    )
    [ [prefix "not" TestTargetNot]
    , [binary "and" TestTargetAnd, binary "or" TestTargetOr]
    ]
 where
  prefix name f = Parser.Prefix (f <$ symbol name)
  binary name f = Parser.InfixL (f <$ symbol name)

  symbol = Parser.L.symbol Parser.space
  parens = Parser.between (symbol "(") (symbol ")")

  everythingParser = TestTargetEverything <$ symbol "*"

  nameParser =
    Parser.label "test name" $
      fmap TestTargetName . Parser.between (symbol "[") (symbol "]") $
        Parser.takeWhile1P Nothing (/= ']')

  markerParser =
    Parser.label "marker" . ignoreSpacesAfter $ do
      _ <- symbol "@"
      fmap TestTargetMarker . Parser.takeWhile1P Nothing $
        (||) <$> isAlphaNum <*> (`elem` ("-_." :: [Char]))

  fileParser =
    Parser.label "test file" . ignoreSpacesAfter $
      fmap (TestTargetFile . Text.unpack) . Parser.takeWhile1P Nothing $
        (||) <$> isAlphaNum <*> (`elem` ("-_./" :: [Char]))

  ignoreSpacesAfter m = m <* Parser.space

showTestTargetParseError :: ParseErrorBundle -> Text
showTestTargetParseError bundle =
  let
    line = Parser.pstateInput $ Parser.bundlePosState bundle
    err = NonEmpty.head $ Parser.bundleErrors bundle
    pointerLen =
      case err of
        Parser.TrivialError _ (Just (Parser.Tokens s)) _ -> length s
        _ -> 1
   in
    Text.concat
      [ "Could not parse test target: " <> Text.pack (Parser.parseErrorTextPretty err)
      , " |\n"
      , " | " <> line <> "\n"
      , " | " <> Text.replicate (Parser.errorOffset err) " " <> Text.replicate pointerLen "^"
      ]