ReduceCSpec.hs

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

module ReduceCSpec where

import Control.Monad
import Data.Function

import System.Directory
import System.FilePath
import Test.Hspec

import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText

import Test.Hspec.Glitter

import qualified Language.C as C
import qualified Text.PrettyPrint as P

import qualified Test.Hspec.Expectations.Pretty as EP

import qualified Control.Monad.IRTree as IRTree
import qualified Control.Monad.RTree as RTree
import Data.Bits
import Data.Functor
import Data.RPath
import Data.String
import qualified Language.C.System.GCC as C
import ReduceC
import System.Directory.Internal.Prelude (tryIOError)
import System.Process.Typed

spec :: Spec
spec = do
  specSmallCases
  specLargeCases

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
          validate cf

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

      onGlitter (expected </> "extract.c") (\fp -> render fp (IRTree.extract (defaultReduceC c))) do
        it "should be parsed equally" . foldMap $ \cf -> do
          C.parseCFilePre cf >>= \case
            Left err -> fail (show err)
            Right c' -> c' $> () `shouldBe` c $> ()

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

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.c") (\fp -> render fp 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' -> c' $> () `EP.shouldBe` 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
            forM_ (RTree.iinputs (defaultReduceC c)) \(i, _) -> do
              let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
              renderWithChoices rfile (IRTree.probe (defaultReduceC c) i)
        )
        do
          it "should validate all reductions" $ \a -> do
            when (takeExtension a == ".c") do
              validate a

validate :: FilePath -> IO ()
validate 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")

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'