ReduceCSpec.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module ReduceCSpec where

import Control.Monad
import qualified Control.Monad.IRTree as IRTree
import qualified Control.Monad.RTree as RTree
import Data.Bits
import Data.Function
import Data.Functor
import Data.RPath
import Data.String
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Language.C as C
import qualified Language.C.System.GCC as C
import ReduceC
import System.Directory
import System.Directory.Internal.Prelude (tryIOError)
import System.FilePath
import System.Process.Typed
import Test.Hspec
import qualified Test.Hspec.Expectations.Pretty as EP
import Test.Hspec.Glitter
import qualified Text.PrettyPrint as P

spec :: Spec
spec = do
  specSmallCases
  specLargeCases

specSmallCases :: Spec
specSmallCases = do
  let testcases = "test" </> "cases" </> "small"
  cases <- runIO (listDirectory testcases)

  forM_ cases \cname -> do
    let cfrom = testcases </> cname

    describe cfrom do
      c <- runIO $ parse cfrom

      let expected = "test" </> "expected" </> dropExtensions cname

      -- onGlitter (expected </> "main.hs") (\f -> LazyText.writeFile f (PS.pShowNoColor (void c))) do
      --   pure ()

      onGlitter (expected </> "main.c") (`render` c) do
        it "should be valid" . foldMap $ \cf -> do
          validate cf

        it "should be parsed equally" . foldMap $ \cf -> do
          C.parseCFilePre cf >>= \case
            Left err -> fail (show err)
            Right c' -> void c' `EP.shouldBe` void c

      describe "reduction" do
        it "should extract itself" do
          IRTree.extract (defaultReduceC c) $> () `EP.shouldBe` c $> ()

      onGlitterEach
        (expected </> "reduction")
        ( \a -> do
            _ <- tryIOError (removeDirectoryRecursive a)
            createDirectoryIfMissing True a
            let examples = RTree.iinputs (defaultReduceC c)
            forM_ examples \(i, _) -> do
              let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
              renderWithChoices rfile (IRTree.probe (defaultReduceC c) i)
            if length examples > 50
              then fail "too many examples - simplify test case"
              else pure ()
        )
        do
          it "should validate all reductions" $ \a -> do
            when (takeExtension a == ".c") do
              validate a

specLargeCases :: Spec
specLargeCases = do
  cases <- runIO (listDirectory "test/cases/large")

  forM_ cases \cname -> do
    let cfrom = "test" </> "cases" </> "large" </> cname
    let expected = "test" </> "expected" </> dropExtensions cname

    describe cfrom do
      c <- runIO $ parse cfrom

      onGlitter (expected </> "main.c") (`render` c) do
        it "should be valid" . foldMap $ \cf -> do
          simplevalidate cf

        it "should be parsed equally" . foldMap $ \cf -> do
          C.parseCFilePre cf >>= \case
            Left err -> fail (show err)
            Right c' -> c' $> () `shouldBe` c $> ()

      onGlitterEach (expected </> "extract.c") (\fp -> render fp (IRTree.extract (defaultReduceC c))) do
        it "should be parsed equally" $ \cf -> do
          C.parseCFilePre cf >>= \case
            Left err -> fail (show err)
            Right c' -> when (void c' /= void c) do
              expectationFailure "did not parse as we extracted"

      onGlitterEach
        (expected </> "reduction")
        ( \fp -> do
            _ <- tryIOError (removeDirectoryRecursive fp)
            createDirectoryIfMissing True fp
            0 & fix \rec n -> do
              let idx = fromString (replicate (1 `shiftL` n) '1')
              let (c', t, _) = IRTree.probe (defaultReduceC c) idx
              render (fp </> "x" <> show n <.> "c") c'
              renderChoices (fp </> "p" <> show n <.> "path") t
              unless (all ((/= Undecided) . choice) t) do
                rec (n + 1)
        )
        do
          it "should validate all reductions" $ \a -> do
            when (takeExtension a == ".c") do
              simplevalidate a

validate :: FilePath -> IO ()
validate fp = do
  (ec, _, stderr_) <-
    readProcess
      ( proc
          "clang"
          [ "-Werror"
          , "-Wno-error=unused-value"
          , "-Wno-error=return-type"
          , "-Wno-error=incompatible-library-redeclaration"
          , "-o"
          , "/dev/null"
          , fp
          ]
      )
  case ec of
    ExitFailure _ ->
      expectationFailure $
        "could not validate "
          <> show fp
          <> "\n"
          <> ( LazyText.unpack
                . LazyText.unlines
                . filter (LazyText.isInfixOf "error")
                . LazyText.lines
                $ LazyText.decodeUtf8 stderr_
             )
    ExitSuccess -> pure ()

simplevalidate :: FilePath -> IO ()
simplevalidate fp = do
  (ec, _, stderr_) <-
    readProcess (proc "clang" ["-o", "/dev/null", fp])
  case ec of
    ExitFailure _ ->
      expectationFailure $
        "could not validate "
          <> show fp
          <> "\n"
          <> ( LazyText.unpack
                . LazyText.unlines
                . filter (LazyText.isInfixOf "error")
                . LazyText.lines
                $ LazyText.decodeUtf8 stderr_
             )
    ExitSuccess -> pure ()

render :: FilePath -> C.CTranslUnit -> IO ()
render cto c = do
  createDirectoryIfMissing True (takeDirectory cto)
  writeFile cto (P.render (C.pretty c) <> "\n")

renderChoices :: FilePath -> [AnnotatedChoice (String, C.Position)] -> IO ()
renderChoices file as =
  writeFile
    file
    ( ( unlines
          . map
            ( \(AnnotatedChoice cs (reason, pos)) ->
                [debugShowChoice cs] <> " " <> reason <> " at " <> show pos
            )
          $ as
      )
        <> "\n"
    )

renderWithChoices :: FilePath -> (C.CTranslUnit, [AnnotatedChoice (String, C.Position)], Int) -> IO ()
renderWithChoices file (c, a, _) = do
  createDirectoryIfMissing True (takeDirectory file)
  writeFile
    file
    ( ( unlines
          . map
            ( \(AnnotatedChoice cs (reason, pos)) ->
                "// " <> [debugShowChoice cs] <> " " <> reason <> " at " <> show pos
            )
          $ a
      )
        <> "\n"
    )

  appendFile
    file
    (P.render (C.pretty c) <> "\n")

parse :: FilePath -> IO C.CTranslUnit
parse cfrom = do
  cf <- C.parseCFile (C.newGCC "clang") Nothing [] cfrom
  case cf of
    Left err -> fail (show err)
    Right cf' -> pure cf'