PyF-0.10.0.1: test/SpecFail.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.DeepSeq
import Control.Exception
import qualified Data.Text as Text
import System.Exit
import System.FilePath
import qualified System.IO as IO
import System.IO.Temp
import System.Process (readProcessWithExitCode)
import Test.HUnit.Lang
import Test.Hspec

-- * Check compilation with external GHC (this is usefull to test compilation failure)

data CompilationStatus
  = -- | Fails during compilation (with error)
    CompileError String
  | RuntimeError String
  | Ok String
  deriving (Show, Eq)

makeTemplate :: String -> String
makeTemplate s = "{-# LANGUAGE QuasiQuotes, ExtendedDefaultRules, TypeApplications #-}\nimport PyF\ntruncate' = truncate @Float @Int\nhello = \"hello\"\nnumber = 3.14 :: Float\nmain :: IO ()\nmain = putStrLn [fmt|" ++ s ++ "|]\n"

-- | Compile a formatting string
--
-- >>> checkCompile fileContent
-- CompileError "Bla bla bla, Floating cannot be formatted as hexa (`x`)
checkCompile :: HasCallStack => String -> IO CompilationStatus
checkCompile content = withSystemTempFile "PyFTest.hs" $ \path fd -> do
  IO.hPutStr fd content
  IO.hFlush fd
  (ecode, _stdout, stderr) <-
    readProcessWithExitCode
      "ghc"
      [ path,
        -- Include all PyF files
        "-isrc",
        -- Disable the usage of the annoying .ghc environment file
        "-package-env",
        "-",
        -- Tests use a filename in a temporary directory which may have a long filename which triggers
        -- line wrapping, reducing the reproducibility of error message
        -- By setting the column size to a high value, we ensure reproducible error messages
        "-dppr-cols=10000000000000",
        -- Clean package environment
        "-hide-all-packages",
        "-package base",
        "-package bytestring",
        "-package parsec",
        "-package text",
        "-package template-haskell",
        "-package ghc-boot",
        "-package mtl",
        "-package ghc",
        "-package time",
        "-package containers"
      ]
      ""
  case ecode of
    ExitFailure _ -> pure (CompileError (sanitize path stderr))
    ExitSuccess -> do
      (ecode', stdout', stderr') <- readProcessWithExitCode (take (length path - 3) path) [] ""
      case ecode' of
        ExitFailure _ -> pure (RuntimeError stderr')
        ExitSuccess -> pure (Ok stdout')

-- sanitize a compilation result by removing variables strings such as
-- temporary files name
sanitize :: FilePath -> String -> String
sanitize path =
  Text.unpack
    -- Strip the filename
    . Text.replace (Text.pack path) (Text.pack "INITIALPATH")
    -- GHC 9.0 replaces [Char] by String everywhere
    . Text.replace (Text.pack "[Char]") (Text.pack "String")
    . Text.pack

golden :: HasCallStack => String -> String -> IO ()
golden name output = do
  let goldenFile = "test/golden" </> (name <> ".golden")
      actualFile = "test/golden" </> (name <> ".actual")
  -- It can fail if the golden file does not exists
  goldenContentE :: Either SomeException String <- try $ readFile goldenFile
  let -- if no golden file, the golden file is the content
      goldenContent = case goldenContentE of
        Right e -> e
        Left _ -> output
  -- Flush lazy IO
  _ <- evaluate (force goldenContent)
  if output /= goldenContent
    then do
      writeFile actualFile output
      (_, diffOutput, _) <- readProcessWithExitCode "diff" [goldenFile, actualFile] ""
      putStrLn diffOutput
      -- Update golden file
      writeFile goldenFile output
      assertFailure diffOutput
    else writeFile goldenFile output

failCompile :: HasCallStack => String -> Spec
failCompile s = failCompileContent s s (makeTemplate s)

failCompileContent :: HasCallStack => String -> String -> String -> Spec
failCompileContent h caption fileContent =
  before (checkCompile fileContent) $ do
    let goldenPath = concatMap cleanSpecialChars h
    it (show caption) $ \res -> case res of
      CompileError output -> golden goldenPath output
      _ -> assertFailure (show $ ".golden/" <> goldenPath <> "\n" <> show res)

-- Remove chars which are not accepted in a path name
cleanSpecialChars :: Char -> [Char]
cleanSpecialChars '/' = "SLASH"
cleanSpecialChars '\\' = "BACKSLASH"
cleanSpecialChars ':' = "COLON"
cleanSpecialChars '\n' = "NEWLINE"
cleanSpecialChars e = pure e

main :: IO ()
main = hspec spec

spec :: Spec
spec =
  describe "error reporting" $ do
    describe "string" $ do
      describe "integral / fractional qualifiers" $ do
        failCompile "{hello:f}"
        failCompile "{hello:d}"
        failCompile "{hello:e}"
        failCompile "{hello:b}"
        failCompile "{hello:E}"
        failCompile "{hello:G}"
        failCompile "{hello:g}"
        failCompile "{hello:%}"
        failCompile "{hello:x}"
        failCompile "{hello:X}"
        failCompile "{hello:o}"
      describe "padding center" $ do
        failCompile "{hello:=100s}"
        failCompile "{hello:=100}"
      describe "grouping" $ do
        failCompile "{hello:_s}"
        failCompile "{hello:,s}"
      describe "sign" $ do
        failCompile "{hello:+s}"
        failCompile "{hello: s}"
        failCompile "{hello:-s}"
    describe "number with precision" $ do
      failCompile "{truncate number:.3d}"
      failCompile "{truncate number:.3o}"
      failCompile "{truncate number:.3b}"
      failCompile "{truncate number:.3x}"
    describe "floats" $ do
      failCompile "{number:o}"
      failCompile "{number:b}"
      failCompile "{number:x}"
      failCompile "{number:X}"
      failCompile "{number:d}"
    -- XXX: this are not failing for now, it should be fixed
    xdescribe "not specified" $ do
      failCompile "{truncate number:.3}"
      failCompile "{hello:#}"
      failCompile "{hello:+}"
      failCompile "{hello: }"
      failCompile "{hello:-}"
      failCompile "{hello:_}"
      failCompile "{hello:,}"
    describe "multiples lines" $
      failCompile "hello\n\n\n{pi:l}"
    describe "on haskell expression parsing" $ do
      describe "single line" $
        failCompile "{1 + - / lalalal}"
      describe "empty expression" $
        failCompile "{}"
      describe "sub expression" $ do
        describe "simple failure" $
          failCompile "{pi:.{/}}"
        describe "empty failure" $
          failCompile "{pi:.{}}"
      describe "multiples lines" $
        failCompile "hello\n    {\nlet a = 5\n    b = 10\nin 1 + - / lalalal}"
    describe "non-doubled delimiters" $ do
      failCompile "hello } world"
      failCompile "hello { world"
    describe "lexical errors" $ do
      describe "single line" $
        failCompile "foo\\Pbar"
      describe "multiple line" $
        failCompile "foo\nbli\\Pbar"
    describe "Wrong type" $ do
      failCompile "{True}"
      failCompile "{True:f}"
      failCompile "{True:d}"