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

module ReduceCSpec where

import Control.Monad

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

import Test.Hspec.Glitter

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

import Control.Monad.RTree (extract, iinputs)
import Data.Functor
import Data.RPath
import qualified Language.C.System.GCC as C
import ReduceC
import System.Process.Typed

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

  forM_ cases \cname -> do
    let cfrom = "test/cases" </> cname </> "main.c"
    let expected = "test/expected" </> cname
    onGlitterWith
      (expected </> "pp.c")
      (preproc cfrom)
      do
        it "should be valid" \(cf, _) ->
          validate cf

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

        describe "reduction" do
          it "should extract itself" \(_, c) -> do
            extract (reduceC c) `shouldBe` c

    onGlitterWith
      (expected </> "reduction")
      ( \a () -> do
          c <- parse cfrom
          createDirectoryIfMissing True a
          forM_ (take 20 $ iinputs (reduceC c)) \(i, c') -> do
            let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
            render rfile c'
          pure a
      )
      do
        it "should validate all reductions" \a -> do
          listDirectory a >>= mapM_ \x ->
            validate (a </> x)

validate :: FilePath -> IO ()
validate fp = do
  ec <- runProcess (proc "clang" ["-o", "/dev/null", fp])
  case ec of
    ExitFailure _ -> fail ("could not validate " <> show fp)
    ExitSuccess -> pure ()

render :: FilePath -> C.CTranslUnit -> IO ()
render cto c = do
  createDirectoryIfMissing True (takeDirectory cto)
  writeFile cto (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'

preproc :: FilePath -> FilePath -> () -> IO (FilePath, C.CTranslUnit)
preproc cfrom cto _ = do
  cf' <- parse cfrom
  render cto cf'
  pure (cfrom, cf')