snippet-0.1.0.3: test/SnippetSpec.hs

{-# OPTIONS_GHC -Wno-orphans #-}

module SnippetSpec
  ( spec
  ) where

import Prelude

import Control.Monad (guard)
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (traverse_)
import Data.List.NonEmpty (nonEmpty)
import Data.Semigroup (Endo (..))
import Data.Text (Text, pack)
import Data.Text qualified as T
import Data.Yaml qualified as Yaml
import GHC.Generics (Generic)
import Prettyprinter (defaultLayoutOptions, layoutPretty, reAnnotate)
import Prettyprinter.Render.Terminal qualified as ANSI
import Prettyprinter.Render.Text qualified as Text
import Snippet
import Snippet.Pretty (annToAnsi, prettySnippet)
import System.Environment (lookupEnv)
import System.FilePath (dropTrailingPathSeparator, splitPath)
import System.FilePath.Glob (globDir1)
import Test.Hspec

spec :: Spec
spec = do
  gs <- runIO $ loadGoldens "test-cases"
  traverse_ goldenSpec gs

instance FromJSON Region

instance ToJSON Region

data Golden = Golden
  { path :: FilePath
  , fixture :: GoldenFixture
  }

data GoldenFixture = GoldenFixture
  { input :: GoldenInput
  , expected :: Maybe GoldenSnippet
  }
  deriving stock (Generic)
  deriving anyclass (FromJSON, ToJSON)

data GoldenInput = GoldentInput
  { region :: Region
  , source :: Text
  , sourceStartLine :: Maybe Int
  }
  deriving stock (Generic)
  deriving anyclass (FromJSON, ToJSON)

data GoldenSnippet = GoldenSnippet
  { text :: Text
  , ansi :: Text
  }
  deriving stock (Generic)
  deriving anyclass (FromJSON, ToJSON)

loadGoldens :: FilePath -> IO [Golden]
loadGoldens base = do
  yamls <- globDir1 "**/*.yaml" base
  traverse loadGolden yamls

loadGolden :: FilePath -> IO Golden
loadGolden path = do
  fixture <- Yaml.decodeFileThrow path
  pure $ Golden {path, fixture}

goldenSpec :: Golden -> Spec
goldenSpec g = go $ map dropTrailingPathSeparator $ splitPath g.path
 where
  go = \case
    [] -> it g.path $ goldenIt g
    [p] -> it p $ goldenIt g
    (p : ps) -> context p $ go ps

goldenIt :: Golden -> Expectation
goldenIt g = do
  update <- lookupEnvYes "SNIPPET_TEST_GOLDEN_UPDATE"
  actual <- decodeGolden g

  let mExpected = do
        guard $ not update
        g.fixture.expected

  case mExpected of
    Nothing -> encodeGolden g actual
    Just expected -> do
      -- If both are wrong, we'd like to work on the text failure first
      actual.text `shouldBe` expected.text
      actual.ansi `shouldBe` expected.ansi

decodeGolden :: Golden -> IO GoldenSnippet
decodeGolden g = do
  snippet <-
    maybe err (pure . mkSnippet)
      $ nonEmpty
      $ T.lines
      $ g.fixture.input.source

  let simple =
        layoutPretty defaultLayoutOptions
          $ reAnnotate annToAnsi
          $ prettySnippet snippet

  pure
    $ GoldenSnippet
      { text = Text.renderStrict simple
      , ansi = replaceEscapes $ ANSI.renderStrict simple
      }
 where
  mkSnippet =
    snippetFromContents
      g.fixture.input.region
      (pack g.path)
      g.fixture.input.sourceStartLine

  err = do
    expectationFailure "Fixture region was invalid"
    error "unreachable"

encodeGolden :: Golden -> GoldenSnippet -> IO ()
encodeGolden g gs =
  Yaml.encodeFile g.path $ g.fixture {expected = Just gs}

replaceEscapes :: Text -> Text
replaceEscapes = appEndo $ foldMap (uncurry toEndo) escapes
 where
  toEndo :: Text -> Text -> Endo Text
  toEndo a b = Endo $ T.replace a b

  escapes :: [(Text, Text)]
  escapes =
    [ ("\ESC[0;36m", "{c}")
    , ("\ESC[0;34m", "{b}")
    , ("\ESC[0;32m", "{g}")
    , ("\ESC[0;31m", "{r}")
    , ("\ESC[0;1m", "{B}")
    , ("\ESC[0m", "{x}")
    ]

lookupEnvYes :: String -> IO Bool
lookupEnvYes e = maybe False isYes <$> lookupEnv e
 where
  isYes x =
    any
      ((normalize x ==) . normalize)
      [ "1"
      , "y"
      , "yes"
      , "true"
      , "on"
      ]

  normalize :: String -> Text
  normalize = T.toCaseFold . T.strip . pack